View Issue Details

IDProjectCategoryView StatusLast Update
0034772FPCCompilerpublic2019-05-15 16:30
ReporterMartin FriebeAssigned ToSergei Gorelkin 
PriorityhighSeveritycrashReproducibilityalways
Status assignedResolutionopen 
Platform64bit IntelOSwin 10OS Version10
Product Version3.3.1Product Build40680 
Target VersionFixed in Version 
Summary0034772: Win64 (seh) compiled exe crashes, because implicit finally handler is entered twice.
DescriptionThis happens on Win64 only (seh specific) / *not* tested with the 32 bit seh...


See code in "steps to reproduce"

compiled with -gh (tested with -gh -gt -gw) crashes.

The procedure allocates memory for a local copy of "a: array of integer"

When "exit" is executed, _FPC_local_unwind is called. This calls the finally handlers (both the user one, and the implicit one).

The following code is generated (-al)

>>>>>>>>>>>>>>>>>
.seh_handler __FPC_specific_handler,@unwind
.seh_handlerdata
    .long 2
    .long 0
    .rva .Lj14
    .rva .Lj15
    .rva P$PROJECT1$_$FOO$array_of_LONGINT_$$_fin$0
    .long 0
    .rva .Lj9
    .rva .Lj10
    .rva P$PROJECT1$_$FOO$array_of_LONGINT_$$_fin$1
<<<<<<<<<<<<<<<<

Lj10 is BEFORE the call to the implicit finally

.Lj10:
.Lj11:
    movq %rbp,%rcx
    call P$PROJECT1$_$FOO$array_of_LONGINT_$$_fin$1

So after unwind finishes, the implicit finally handler is called a 2nd time (setting a breakpoint in asm proves this).

The memory for "a" is attempted to be freed a 2nd time, which crashes the app.
Steps To Reproduceprogram project1;
{$mode objfpc}
uses
  Classes;

procedure Foo(a: array of integer);
begin
  try
    writeln(a[0]);
    if a[0] = 1 then exit;
    writeln(a[0]);
  finally
    writeln(a[0]);
  end;
end;

begin
  foo([1]);
end.
TagsNo tags attached.
Fixed in Revision
FPCOldBugId0
FPCTarget
Attached Files
  • project1.zip (1,195 bytes)
  • x86_64-win64_project1.s.zip (4,620 bytes)
  • i386-win32_project1.s.zip (4,106 bytes)
  • nx64flw.pas.patch (2,794 bytes)
    Index: nx64flw.pas
    ===================================================================
    --- nx64flw.pas	(revision 41795)
    +++ nx64flw.pas	(working copy)
    @@ -223,6 +223,7 @@
         endtrylabel,
         finallylabel,
         endfinallylabel,
    +    templabel,
         oldexitlabel: tasmlabel;
         oldflowcontrol: tflowcontrol;
         catch_frame: boolean;
    @@ -244,6 +245,7 @@
         oldflowcontrol:=flowcontrol;
         flowcontrol:=[fc_inflowcontrol];
     
    +    templabel:=nil;
         current_asmdata.getjumplabel(trylabel);
         current_asmdata.getjumplabel(endtrylabel);
         current_asmdata.getjumplabel(finallylabel);
    @@ -284,20 +286,19 @@
               exit;
           end;
     
    -    { If the immediately preceding instruction is CALL,
    -      its return address must not end up outside the scope, so pad with NOP. }
    +    { finallylabel is only used in implicit frames as an exit point from nested try..finally
    +      statements, if any. To prevent finalizer from being executed twice, it must come before
    +      endtrylabel (bug #34772) }
         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
    +        current_asmdata.getjumplabel(templabel);
    +        cg.a_label(current_asmdata.CurrAsmList, finallylabel);
    +        { jump over exception handler }
    +        cg.a_jmp_always(current_asmdata.CurrAsmList,templabel);
    +        { 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. }
    +        cg.a_label(current_asmdata.CurrAsmList,endtrylabel);
             if (current_procinfo.procdef.proccalloption=pocall_safecall) then
               begin
                 handle_safecall_exception;
    @@ -305,10 +306,18 @@
               end
             else
               InternalError(2014031601);
    +        cg.a_label(current_asmdata.CurrAsmList,templabel);
    +      end
    +    else
    +      begin
    +        { same as emit_nop but using finallylabel instead of dummy }
    +        cg.a_label(current_asmdata.CurrAsmList,finallylabel);
    +        finallylabel.increfs;
    +        current_asmdata.CurrAsmList.concat(Taicpu.op_none(A_NOP,S_NO));
    +        cg.a_label(current_asmdata.CurrAsmList,endtrylabel);
           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);
    
    nx64flw.pas.patch (2,794 bytes)
  • 34772.pas (847 bytes)
    { %OPT=-gh }
    {$mode objfpc}{$h+}
     uses
       Classes;
    
    procedure Foo(a: array of integer);
    begin
      try
        writeln(a[0]);
        if a[0] = 1 then exit;
        writeln(a[0]);
      finally
        writeln(a[0]);
      end;
    end;
    
    procedure Bar(a: array of integer); safecall;
    begin
      try
        writeln(a[0]);
        if a[0] = 1 then exit;
        writeln(a[0]);
      finally
        writeln(a[0]);
      end;
    end;
    
    var
      memmgr, newmemmgr: TMemoryManager;
      FreeMemCalls: Longint;
      
    
    function HookFreeMem(ptr: Pointer): ptruint;
    begin
      Inc(FreeMemCalls);
      result := memmgr.FreeMem(ptr);
    end;
    
    begin
      GetMemoryManager(memmgr);
      newmemmgr := memmgr;
      newmemmgr.FreeMem := @HookFreeMem;
      SetMemoryManager(newmemmgr);
    
      FreeMemCalls:=0;
      foo([1]);
      if FreeMemCalls<>1 then halt(1);
      bar([1]);
      if FreeMemCalls<>2 then halt(2);
    end.
    
    34772.pas (847 bytes)
  • i34772.patch (2,676 bytes)
    Index: compiler/ncgflw.pas
    ===================================================================
    --- compiler/ncgflw.pas	(revision 41898)
    +++ compiler/ncgflw.pas	(working copy)
    @@ -424,7 +424,10 @@
                secondpass(left);
     
              if (fc_unwind_exit in flowcontrol) then
    -           hlcg.g_local_unwind(current_asmdata.CurrAsmList,current_procinfo.CurrExitLabel)
    +           { Use TrueExitLabel, not CurrExitLabel, because if there's an implicit finally
    +             block, this will also be inside the unwinding information, and jumping to
    +             CurrExitLabel might call the implicit finally block a second time. [Kit] [Issue #34772] }
    +           hlcg.g_local_unwind(current_asmdata.CurrAsmList,current_procinfo.TrueExitLabel)
              else
                hlcg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrExitLabel);
            end;
    Index: compiler/procinfo.pas
    ===================================================================
    --- compiler/procinfo.pas	(revision 41898)
    +++ compiler/procinfo.pas	(working copy)
    @@ -117,6 +117,9 @@
               { label to leave the sub routine }
               CurrExitLabel : tasmlabel;
     
    +          { True exit label (used as the exit point for stack unwinding on some platforms) }
    +          TrueExitLabel : tasmlabel;
    +
               { label for nested exits }
               nestedexitlabel : tlabelsym;
     
    @@ -215,6 +218,7 @@
             reference_reset(save_regs_ref,sizeof(aint),[]);
             { labels }
             current_asmdata.getjumplabel(CurrExitLabel);
    +        TrueExitLabel := CurrExitLabel; { This label doesn't change }
             current_asmdata.getjumplabel(CurrGOTLabel);
             CurrBreakLabel:=nil;
             CurrContinueLabel:=nil;
    Index: compiler/x86_64/nx64flw.pas
    ===================================================================
    --- compiler/x86_64/nx64flw.pas	(revision 41898)
    +++ compiler/x86_64/nx64flw.pas	(working copy)
    @@ -472,7 +472,10 @@
             cg.a_label(current_asmdata.CurrAsmList,exitexceptlabel);
             cg.g_call(current_asmdata.CurrAsmList,'FPC_DONEEXCEPTION');
             if (fc_unwind_exit in oldflowcontrol) then
    -          cg.g_local_unwind(current_asmdata.CurrAsmList,oldCurrExitLabel)
    +          { Use TrueExitLabel, not oldCurrExitLabel, because if there's an implicit finally
    +            block, this will also be inside the unwinding information, and jumping to
    +            oldCurrExitLabel might call the implicit finally block a second time. [Kit] [Issue #34772] }
    +          cg.g_local_unwind(current_asmdata.CurrAsmList,current_procinfo.TrueExitLabel)
             else
               cg.a_jmp_always(current_asmdata.CurrAsmList,oldCurrExitLabel);
           end;
    
    i34772.patch (2,676 bytes)
  • tw34772.pp (12,098 bytes)
    program tw34772;
    
    {$mode objfpc}{$H+}
    {$WARN 5058 off : Variable "$1" does not seem to be initialized}
    
    uses
      Classes, SysUtils;
    
    
    procedure Test1(a: array of Integer);
    begin
      WriteLn('Test1 - Start ', a[0]);
      if a[0] = 1 then exit;
      if a[0] = 2 then raise EAbort.Create('Test');
      WriteLn('Test1 - End ', a[0]);
    end;
    
    
    procedure Test2(a: array of Integer);
    var
      Test: Pointer;
    begin
      GetMem(Test, 4);
      try
        WriteLn('Test2 - Start ', a[0]);
        if a[0] = 1 then exit;
        if a[0] = 2 then raise EAbort.Create('Test');
        WriteLn('Test2 - End ', a[0]);
      finally
        FreeMem(Test);
        WriteLn('Test2 - Finally ', a[0]);
      end;
    end;
    
    
    procedure Test3(a: array of Integer);
    begin
      try
        WriteLn('Test3 - Start ', a[0]);
        if a[0] = 1 then exit;
        if a[0] = 2 then raise EAbort.Create('Test');
        WriteLn('Test3 - End ', a[0]);
      except
        on E: Exception do
          begin
            if E.ClassType <> EAbort then raise; { Unexpected exception }
            WriteLn('Test3 - Except ', a[0]);
          end;
      end;
    end;
    
    
    procedure Test4(a: array of Integer);
    var
      Test: Pointer;
    begin
      GetMem(Test, 4);
      try
        try
          WriteLn('Test4 - Start ', a[0]);
          if a[0] = 1 then exit;
          if a[0] = 2 then raise EAbort.Create('Test');
          WriteLn('Test4 - End ', a[0]);
        except
          on E: Exception do
            begin
              if E.ClassType <> EAbort then raise; { Unexpected exception }
              WriteLn('Test4 - Except ', a[0]);
            end;
        end;
      finally
        FreeMem(Test);
        WriteLn('Test4 - Finally ', a[0]);
      end;
    end;
    
    
    procedure Test5(a: array of Integer); safecall;
    begin
      WriteLn('Test5 - Start ', a[0]);
      if a[0] = 1 then exit;
      if a[0] = 2 then raise EAbort.Create('Test');
      WriteLn('Test5 - End ', a[0]);
    end;
    
    
    procedure Test6(a: array of Integer); safecall;
    var
      Test: Pointer;
    begin
      GetMem(Test, 4);
      try
        WriteLn('Test6 - Start ', a[0]);
        if a[0] = 1 then exit;
        if a[0] = 2 then raise EAbort.Create('Test');
        WriteLn('Test6 - End ', a[0]);
      finally
        FreeMem(Test);
        WriteLn('Test6 - Finally ', a[0]);
      end;
    end;
    
    
    procedure Test7(a: array of Integer); safecall;
    begin
      try
        WriteLn('Test7 - Start ', a[0]);
        if a[0] = 1 then exit;
        if a[0] = 2 then raise EAbort.Create('Test');
        WriteLn('Test7 - End ', a[0]);
      except
        on E: Exception do
          begin
            if E.ClassType <> EAbort then raise; { Unexpected exception }
            WriteLn('Test7 - Except ', a[0]);
          end;
      end;
    end;
    
    
    procedure Test8(a: array of Integer); safecall;
    var
      Test: Pointer;
    begin
      GetMem(Test, 4);
      try
        try
          WriteLn('Test8 - Start ', a[0]);
          if a[0] = 1 then exit;
          if a[0] = 2 then raise EAbort.Create('Test');
          WriteLn('Test8 - End ', a[0]);
        except
          on E: Exception do
            begin
              if E.ClassType <> EAbort then raise; { Unexpected exception }
              WriteLn('Test8 - Except ', a[0]);
            end;
        end;
      finally
        FreeMem(Test);
        WriteLn('Test8 - Finally ', a[0]);
      end;
    end;
    
    
    function Test9(a: array of Integer): Boolean;
    var
      Test: Pointer;
    begin
      Result := True;
      GetMem(Test, 4);
      try
        WriteLn('Test9 - Start ', a[0]);
        if a[0] = 1 then exit;
        if a[0] = 2 then raise EAbort.Create('Test');
        WriteLn('Test9 - End ', a[0]);
      finally
        FreeMem(Test);
        WriteLn('Test9 - Finally ', a[0]);
        if a[0] = 0 then Result := False;
      end;
    
      Result := True;
    
    end;
    
    
    procedure Test10(a: array of Integer);
    var
      Test, Test2: Pointer;
    begin
      GetMem(Test, 4);
      try
        GetMem(Test2, 4);
        try
          WriteLn('Test10 - Start ', a[0]);
          if a[0] = 1 then exit;
          if a[0] = 2 then raise EAbort.Create('Test');
          WriteLn('Test10 - End ', a[0]);
        finally
          FreeMem(Test2);
          WriteLn('Test10 - Finally A ', a[0]);
        end;
      finally
        FreeMem(Test);
        WriteLn('Test10 - Finally B ', a[0]);
      end;
    end;
    
    
    procedure Test11(a: array of Integer); safecall;
    var
      Test, Test2: Pointer;
    begin
      GetMem(Test, 4);
      try
        GetMem(Test2, 4);
        try
          WriteLn('Test11 - Start ', a[0]);
          if a[0] = 1 then exit;
          if a[0] = 2 then raise EAbort.Create('Test');
          WriteLn('Test11 - End ', a[0]);
        finally
          FreeMem(Test2);
          WriteLn('Test11 - Finally A ', a[0]);
        end;
      finally
        FreeMem(Test);
        WriteLn('Test11 - Finally B ', a[0]);
      end;
    end;
    
    
    procedure Test12(a: Integer); safecall;
    var
      Test, Test2: Pointer;
    begin
      GetMem(Test, 4);
      try
        GetMem(Test2, 4);
        try
          WriteLn('Test12 - Start ', a);
          if a = 1 then exit;
          if a = 2 then raise EAbort.Create('Test');
          WriteLn('Test12 - End ', a);
        finally
          FreeMem(Test2);
          WriteLn('Test12 - Finally A ', a);
        end;
      finally
        FreeMem(Test);
        WriteLn('Test12 - Finally B ', a);
      end;
    end;
    
    
    var
      X, TestCount: Integer;
      ReferenceCount: LongInt;
      MemMgr, NewMemMgr: TMemoryManager;
      Fail: Boolean;
    
    function HookGetMem(Size: PtrUInt): Pointer;
      begin
        Inc(ReferenceCount);
        Result := MemMgr.GetMem(Size);
      end;
    
    function HookReAllocMem(var p: Pointer; Size: PtrUInt): Pointer;
      begin
        if p = nil then
          Inc(ReferenceCount);
    
        Result := MemMgr.ReAllocMem(p, Size);
    
        { If ReAllocMem(nil, 0) is called, ReferenceCount is incremented then
          decremented, reflecting the null operation }
        if Size = 0 then
          Dec(ReferenceCount);
      end;
    
    function HookFreeMem(ptr: Pointer): PtrUInt;
      begin
        Dec(ReferenceCount);
        Result := MemMgr.FreeMem(ptr);
      end;
    
    function HookFreeMemSize(ptr: Pointer; Size: PtrUInt): PtrUInt;
      begin
        Dec(ReferenceCount);
        Result := MemMgr.FreeMemSize(ptr, Size);
      end;
    
    procedure PostTestAnalysis;
      begin
        Inc(TestCount);
        if ReferenceCount <> 0 then
          begin
            WriteLn('FAIL - Reference count = ', ReferenceCount);
            Fail := True;
          end;
      end;
    
    procedure CheckTestCount;
      begin
        if TestCount <> 3 then
          begin
            Fail := True;
            WriteLn('FAIL - Only ', TestCount, ' sub-tests were run for this test');
          end;
      end;
    
    begin
      { Set up hooks to track memory leaks }
      GetMemoryManager(MemMgr);
      NewMemMgr := MemMgr;
      NewMemMgr.GetMem := @HookGetMem;
      NewMemMgr.ReAllocMem := @HookReAllocMem;
      NewMemMgr.FreeMem := @HookFreeMem;
      NewMemMgr.FreeMemSize := @HookFreeMemSize;
      SetMemoryManager(NewMemMgr);
    
      { Test parameters
        [0] = Run to end of procedure
        [1] = Exit prematurely
        [2] = raise exception
      }
    
      { Test1 - implicit try..finally }
      TestCount := 0;
      for X := 0 to 2 do
        begin
          ReferenceCount := 0;
          try
            Test1([X]);
          except
            on E: Exception do
              if E.ClassType <> EAbort then
                begin
                  { Unexpected exception }
                  WriteLn('FAIL - Exception ', E.ClassName, ' raised: "', E.Message, '"');
                  Fail := True;
                  Continue;
                end;
          end;
    
          PostTestAnalysis;
        end;
    
      CheckTestCount;
    
      { Test2 - implicit + explicit try..finally }
      TestCount := 0;
      for X := 0 to 2 do
        begin
          ReferenceCount := 0;
          try
            Test2([X]);
          except
            on E: Exception do
              if E.ClassType <> EAbort then
                begin
                  { Unexpected exception }
                  WriteLn('FAIL - Exception ', E.ClassName, ' raised: "', E.Message, '"');
                  Fail := True;
                  Continue;
                end;
          end;
    
          PostTestAnalysis;
        end;
    
      CheckTestCount;
    
      { Test3 - implicit try..finally and explicit try..except }
      TestCount := 0;
      for X := 0 to 2 do
        begin
          ReferenceCount := 0;
          try
            Test3([X]);
          except
            { Exceptions should be caught }
            on E: Exception do
              begin
                WriteLn('FAIL - Exception ', E.ClassName, ' raised: "', E.Message, '"');
                Fail := True;
                Continue;
              end;
          end;
    
          PostTestAnalysis;
        end;
    
      CheckTestCount;
    
      { Test4 - implicit + explicit try..finally and explicit try..except }
      TestCount := 0;
      for X := 0 to 2 do
        begin
          ReferenceCount := 0;
          try
            Test4([X]);
          except
            { Exceptions should be caught }
            on E: Exception do
              begin
                WriteLn('FAIL - Exception ', E.ClassName, ' raised: "', E.Message, '"');
                Fail := True;
                Continue;
              end;
          end;
    
          PostTestAnalysis;
        end;
    
      CheckTestCount;
    
      { Test5 - implicit try..finally with safecall }
      TestCount := 0;
      for X := 0 to 2 do
        begin
          ReferenceCount := 0;
          try
            Test5([X]);
          except
            { Everything gets wrapped into a ESafecallException }
          end;
    
          PostTestAnalysis;
        end;
    
      CheckTestCount;
    
      { Test6 - implicit + explicit try..finally with safecall }
      TestCount := 0;
      for X := 0 to 2 do
        begin
          ReferenceCount := 0;
          try
            Test6([X]);
          except
            { Everything gets wrapped into a ESafecallException }
          end;
    
          PostTestAnalysis;
        end;
    
      CheckTestCount;
    
      { Test7 - implicit try..finally and explicit try..except with safecall }
      TestCount := 0;
      for X := 0 to 2 do
        begin
          ReferenceCount := 0;
          try
            Test7([X]);
          except
            { Everything gets wrapped into a ESafecallException }
          end;
    
          PostTestAnalysis;
        end;
    
      CheckTestCount;
    
      { Test8 - implicit + explicit try..finally and explicit try..except with safecall }
      TestCount := 0;
      for X := 0 to 2 do
        begin
          ReferenceCount := 0;
          try
            Test8([X]);
          except
            { Everything gets wrapped into a ESafecallException }
          end;
    
          PostTestAnalysis;
        end;
    
      CheckTestCount;
    
      { Test9 - implicit + explicit try..finally with code following }
      TestCount := 0;
      for X := 0 to 2 do
        begin
          ReferenceCount := 0;
          try
            if not Test9([X]) then
              begin
                WriteLn('FAIL -  Code following finally block wasn''t executed');
                Fail := True;
                Continue;
              end;
          except
            on E: Exception do
              if E.ClassType <> EAbort then
                begin
                  { Unexpected exception }
                  WriteLn('FAIL - Exception ', E.ClassName, ' raised: "', E.Message, '"');
                  Fail := True;
                  Continue;
                end;
          end;
    
          PostTestAnalysis;
        end;
    
      CheckTestCount;
    
      { Test10 - implicit + 2 * explicit try..finally }
      TestCount := 0;
      for X := 0 to 2 do
        begin
          ReferenceCount := 0;
          try
            Test10([X]);
          except
            on E: Exception do
              if E.ClassType <> EAbort then
                begin
                  { Unexpected exception }
                  WriteLn('FAIL - Exception ', E.ClassName, ' raised: "', E.Message, '"');
                  Fail := True;
                  Continue;
                end;
          end;
    
          PostTestAnalysis;
        end;
    
      CheckTestCount;
    
      { Test11 - implicit + 2 * explicit try..finally with safecall }
      TestCount := 0;
      for X := 0 to 2 do
        begin
          ReferenceCount := 0;
          try
            Test11([X]);
          except
            { Everything gets wrapped into a ESafecallException }
          end;
    
          PostTestAnalysis;
        end;
    
      CheckTestCount;
    
      { Test12 - 2 * explicit try..finally with safecall }
      TestCount := 0;
      for X := 0 to 2 do
        begin
          ReferenceCount := 0;
          try
            Test12(X);
          except
            { Everything gets wrapped into a ESafecallException }
          end;
    
          PostTestAnalysis;
        end;
    
      CheckTestCount;
    
      if Fail then
        Halt(1)
      else
        WriteLn('ok');
    end.
    
    tw34772.pp (12,098 bytes)

Activities

Cyrax

2018-12-28 17:11

reporter   ~0112953

i386-win32 (SEH is enabled) works. x86_64-win64 doesn't and produces following exception and its stack trace:
$ .\project1.exe                                                                                                                            
1                                                                                                                                           
1                                                                                                                                           
An unhandled exception occurred at $000000010000E358:                                                                                       
EInvalidPointer: Invalid pointer operation                                                                                                  
  $000000010000E358  SYSFREEMEM_FIXED,  line 1162 of ../inc/heap.inc                                                                        
  $000000010000E52B  SYSFREEMEM,  line 1227 of ../inc/heap.inc                                                                              
  $000000010000CDAA  FREEMEM,  line 324 of ../inc/heap.inc                                                                                  
  $0000000100009CB2  TOBJECT__FREEINSTANCE,  line 447 of ../inc/objpas.inc                                                                  
  $0000000100019507  TFPLIST__DESTROY,  line 113 of ../objpas/classes/lists.inc                                                             
  $0000000100009A8F  TOBJECT__FREE,  line 336 of ../inc/objpas.inc                                                                          
  $000000010002FB3C  FREEANDNIL,  line 160 of ../objpas/sysutils/sysutils.inc                                                               
  $0000000100019C5D  TLIST__DESTROY,  line 663 of ../objpas/classes/lists.inc                                                               
  $0000000100009A8F  TOBJECT__FREE,  line 336 of ../inc/objpas.inc                                                                          
  $000000010001A235  TTHREADLIST__DESTROY,  line 979 of ../objpas/classes/lists.inc                                                         
  $0000000100009A8F  TOBJECT__FREE,  line 336 of ../inc/objpas.inc                                                                          
  $000000010002FB3C  FREEANDNIL,  line 160 of ../objpas/sysutils/sysutils.inc                                                               
  $0000000100020FE6  COMMONCLEANUP,  line 2543 of ../objpas/classes/classes.inc                                                             
  $0000000100029C9E  CLASSES_$$_finalize$,  line 84 of classes.pp                                                                           
  $000000010000C341  FINALIZEUNITS,  line 1013 of ../inc/system.inc                                                                         
  $000000010000C651  INTERNALEXIT,  line 1094 of ../inc/system.inc                                                                          
  $000000010000C6FE  fpc_do_exit,  line 1137 of ../inc/system.inc

Cyrax

2018-12-28 17:13

reporter  

project1.zip (1,195 bytes)

Cyrax

2018-12-28 17:15

reporter  

x86_64-win64_project1.s.zip (4,620 bytes)

Cyrax

2018-12-28 17:16

reporter  

i386-win32_project1.s.zip (4,106 bytes)

Cyrax

2018-12-28 17:56

reporter   ~0112955

Program received signal SIGSEGV, Segmentation fault.                                                                                                                         
0x000000010000a0ac in TOBJECT__INHERITSFROM (self=0x1195068, ACLASS=0x10003eb80) at ../inc/objpas.inc:621                                                                    
621     ../inc/objpas.inc: No such file or directory.                                                                                                                        
(gdb) bt                                                                                                                                                                     
#0  0x000000010000a0ac in TOBJECT__INHERITSFROM (self=0x1195068, ACLASS=0x10003eb80) at ../inc/objpas.inc:621                                                                
0000001  0x0000000100009813 in fpc_do_is (ACLASS=0x10003eb80, AOBJECT=0x11950b0) at ../inc/objpas.inc:42                                                                          
0000002  0x0000000100030154 in CATCHUNHANDLEDEXCEPTION (OBJ=0x11950b0, ADDR=0x10000e358, FRAMECOUNT=9, FRAMES=0x11a50d0) at ../objpas/sysutils/sysutils.inc:310                   
0000003  0x0000000100013ec7 in __FPC_DEFAULT_HANDLER (REC=..., FRAME=0x102feb0, CONTEXT=..., DISPATCH=...) at seh64.inc:422                                                       
0000004  0x00000000779281ad in ntdll!RtlDecodePointer () from C:\Windows\SYSTEM32\ntdll.dll                                                                                       
0000005  0x0000000077917ddc in ntdll!RtlUnwindEx () from C:\Windows\SYSTEM32\ntdll.dll                                                                                            
0000006  0x000000007781052e in RtlUnwindEx () from C:\Windows\system32\kernel32.dll                                                                                               
0000007  0x0000000100013cc6 in __FPC_DEFAULT_HANDLER (REC=..., FRAME=0x102feb0, CONTEXT=..., DISPATCH=...) at seh64.inc:396                                                       
0000008  0x000000007792812d in ntdll!RtlDecodePointer () from C:\Windows\SYSTEM32\ntdll.dll                                                                                       
0000009  0x000000007791855f in ntdll!RtlUnwindEx () from C:\Windows\SYSTEM32\ntdll.dll                                                                                            
0000010 0x000000007794bcb8 in ntdll!KiUserExceptionDispatcher () from C:\Windows\SYSTEM32\ntdll.dll                                                                              
0000011 0x000007fefd70a06d in RaiseException () from C:\Windows\system32\KernelBase.dll                                                                                          
0000012 0x000000010001397a in fpc_raiseexception (OBJ=0x11950b0, ANADDR=0x10000e358, AFRAME=0x102fc90) at seh64.inc:293                                                          
0000013 0x0000000100030661 in RUNERRORTOEXCEPT (ERRNO=204, ADDRESS=0x10000e358, FRAME=0x102fc90) at ../objpas/sysutils/sysutils.inc:440                                          
0000014 0x000000010000c7c4 in HANDLEERRORADDRFRAME (ERRNO=204, ADDR=0x10000e358, FRAME=0x102fc90) at ../inc/system.inc:1205                                                      
0000015 0x000000010000c874 in HANDLEERRORADDRFRAMEIND (ERRNO=204, ADDR=0x10000e358, FRAME=0x102fc90) at ../inc/system.inc:1222                                                   
0000016 0x000000010000c89f in fpc_handleerror (ERRNO=204) at ../inc/system.inc:1242                                                                                              
0000017 0x000000010000e358 in SYSFREEMEM_FIXED (LOC_FREELISTS=0x117cc3a, PMC=0x118d038) at ../inc/heap.inc:1162                                                                  
0000018 0x000000010000e52b in SYSFREEMEM (P=0x118d040) at ../inc/heap.inc:1227                                                                                                   
0000019 0x000000010000c6aa in INTERNALEXIT () at ../inc/system.inc:1106                                                                                                          
0000020 0x000000010000c6fe in fpc_do_exit () at ../inc/system.inc:1137                                                                                                           
0000021 0x000000010000187d in main () at project1.lpr:25

Martin Friebe

2018-12-28 18:06

manager   ~0112957

Just as a note, the same issue would happen with any other data in any other implicit finally handler. (if user try finally blocks are "exit"ed.)

Strings and arrays however are set to nil, when de-ref'ed. So they do not crash.

Still they should only run once.

Sergei Gorelkin

2018-12-28 22:54

developer   ~0112966

Last edited: 2018-12-28 23:08

View 2 revisions

The unwind data looks correct, .Lj10 designates the end of 'try' part of implicit try..finally statement.

It appears that in procedures with only an implicit try..finally, 'exit' statement generates a plain jump to the end of 'try' part, which allows to entirely avoid unwind-related activities and considerably improves performance.

When user try..finally statement is added, 'exit' changes its behavior and generates a call to fpc_local_unwind instead of jump, so that 'finally' part of the inner try..finally can be executed. However the exit label (which becomes the second argument of fpc_local_unwind) looks incorrect in this case, because it is recognized as being outside of outer 'try' statement and unwinding to it calls the finalizer.

Bart Broersma

2018-12-29 18:36

reporter   ~0112985

Not sure if this is relevant in anyway, but FWIW:
While fpc 3.0.4 does not trigger the crash, heaptrace barfs about wrong memory signature:
C:\Users\Bart\LazarusProjecten\bugs\Console\seh>seh
1
1
Marked memory at $00000000000EF130 invalid
Wrong signature $AAAAAAAA instead of 26C33231

Snus

2019-02-28 12:19

reporter   ~0114500

more simple:

program Project1;
 
procedure DoIt(ar: array of const);
begin
  try
    exit;
  finally
  end
end;
 
begin
   DoIt([]);
end.

Sergei Gorelkin

2019-04-19 14:37

developer  

nx64flw.pas.patch (2,794 bytes)
Index: nx64flw.pas
===================================================================
--- nx64flw.pas	(revision 41795)
+++ nx64flw.pas	(working copy)
@@ -223,6 +223,7 @@
     endtrylabel,
     finallylabel,
     endfinallylabel,
+    templabel,
     oldexitlabel: tasmlabel;
     oldflowcontrol: tflowcontrol;
     catch_frame: boolean;
@@ -244,6 +245,7 @@
     oldflowcontrol:=flowcontrol;
     flowcontrol:=[fc_inflowcontrol];
 
+    templabel:=nil;
     current_asmdata.getjumplabel(trylabel);
     current_asmdata.getjumplabel(endtrylabel);
     current_asmdata.getjumplabel(finallylabel);
@@ -284,20 +286,19 @@
           exit;
       end;
 
-    { If the immediately preceding instruction is CALL,
-      its return address must not end up outside the scope, so pad with NOP. }
+    { finallylabel is only used in implicit frames as an exit point from nested try..finally
+      statements, if any. To prevent finalizer from being executed twice, it must come before
+      endtrylabel (bug #34772) }
     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
+        current_asmdata.getjumplabel(templabel);
+        cg.a_label(current_asmdata.CurrAsmList, finallylabel);
+        { jump over exception handler }
+        cg.a_jmp_always(current_asmdata.CurrAsmList,templabel);
+        { 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. }
+        cg.a_label(current_asmdata.CurrAsmList,endtrylabel);
         if (current_procinfo.procdef.proccalloption=pocall_safecall) then
           begin
             handle_safecall_exception;
@@ -305,10 +306,18 @@
           end
         else
           InternalError(2014031601);
+        cg.a_label(current_asmdata.CurrAsmList,templabel);
+      end
+    else
+      begin
+        { same as emit_nop but using finallylabel instead of dummy }
+        cg.a_label(current_asmdata.CurrAsmList,finallylabel);
+        finallylabel.increfs;
+        current_asmdata.CurrAsmList.concat(Taicpu.op_none(A_NOP,S_NO));
+        cg.a_label(current_asmdata.CurrAsmList,endtrylabel);
       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);
nx64flw.pas.patch (2,794 bytes)

Sergei Gorelkin

2019-04-19 14:38

developer  

34772.pas (847 bytes)
{ %OPT=-gh }
{$mode objfpc}{$h+}
 uses
   Classes;

procedure Foo(a: array of integer);
begin
  try
    writeln(a[0]);
    if a[0] = 1 then exit;
    writeln(a[0]);
  finally
    writeln(a[0]);
  end;
end;

procedure Bar(a: array of integer); safecall;
begin
  try
    writeln(a[0]);
    if a[0] = 1 then exit;
    writeln(a[0]);
  finally
    writeln(a[0]);
  end;
end;

var
  memmgr, newmemmgr: TMemoryManager;
  FreeMemCalls: Longint;
  

function HookFreeMem(ptr: Pointer): ptruint;
begin
  Inc(FreeMemCalls);
  result := memmgr.FreeMem(ptr);
end;

begin
  GetMemoryManager(memmgr);
  newmemmgr := memmgr;
  newmemmgr.FreeMem := @HookFreeMem;
  SetMemoryManager(newmemmgr);

  FreeMemCalls:=0;
  foo([1]);
  if FreeMemCalls<>1 then halt(1);
  bar([1]);
  if FreeMemCalls<>2 then halt(2);
end.
34772.pas (847 bytes)

Sergei Gorelkin

2019-04-19 14:41

developer   ~0115675

I attached the proposed patch which I made some time time ago, and a test, extended to handle the 'safecall' calling convention. The patch solves the issue, but I didn't run the full test suite with it.
Hopefully it saves some work.

J. Gareth Moreton

2019-04-19 14:51

developer   ~0115676

Last edited: 2019-04-19 14:52

View 3 revisions

I too have a solution that is still being run through the regression tests, but is somewhat different to yours. We may have to make comparisons when all is done.

J. Gareth Moreton

2019-04-21 04:31

developer  

i34772.patch (2,676 bytes)
Index: compiler/ncgflw.pas
===================================================================
--- compiler/ncgflw.pas	(revision 41898)
+++ compiler/ncgflw.pas	(working copy)
@@ -424,7 +424,10 @@
            secondpass(left);
 
          if (fc_unwind_exit in flowcontrol) then
-           hlcg.g_local_unwind(current_asmdata.CurrAsmList,current_procinfo.CurrExitLabel)
+           { Use TrueExitLabel, not CurrExitLabel, because if there's an implicit finally
+             block, this will also be inside the unwinding information, and jumping to
+             CurrExitLabel might call the implicit finally block a second time. [Kit] [Issue #34772] }
+           hlcg.g_local_unwind(current_asmdata.CurrAsmList,current_procinfo.TrueExitLabel)
          else
            hlcg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrExitLabel);
        end;
Index: compiler/procinfo.pas
===================================================================
--- compiler/procinfo.pas	(revision 41898)
+++ compiler/procinfo.pas	(working copy)
@@ -117,6 +117,9 @@
           { label to leave the sub routine }
           CurrExitLabel : tasmlabel;
 
+          { True exit label (used as the exit point for stack unwinding on some platforms) }
+          TrueExitLabel : tasmlabel;
+
           { label for nested exits }
           nestedexitlabel : tlabelsym;
 
@@ -215,6 +218,7 @@
         reference_reset(save_regs_ref,sizeof(aint),[]);
         { labels }
         current_asmdata.getjumplabel(CurrExitLabel);
+        TrueExitLabel := CurrExitLabel; { This label doesn't change }
         current_asmdata.getjumplabel(CurrGOTLabel);
         CurrBreakLabel:=nil;
         CurrContinueLabel:=nil;
Index: compiler/x86_64/nx64flw.pas
===================================================================
--- compiler/x86_64/nx64flw.pas	(revision 41898)
+++ compiler/x86_64/nx64flw.pas	(working copy)
@@ -472,7 +472,10 @@
         cg.a_label(current_asmdata.CurrAsmList,exitexceptlabel);
         cg.g_call(current_asmdata.CurrAsmList,'FPC_DONEEXCEPTION');
         if (fc_unwind_exit in oldflowcontrol) then
-          cg.g_local_unwind(current_asmdata.CurrAsmList,oldCurrExitLabel)
+          { Use TrueExitLabel, not oldCurrExitLabel, because if there's an implicit finally
+            block, this will also be inside the unwinding information, and jumping to
+            oldCurrExitLabel might call the implicit finally block a second time. [Kit] [Issue #34772] }
+          cg.g_local_unwind(current_asmdata.CurrAsmList,current_procinfo.TrueExitLabel)
         else
           cg.a_jmp_always(current_asmdata.CurrAsmList,oldCurrExitLabel);
       end;
i34772.patch (2,676 bytes)

J. Gareth Moreton

2019-04-21 04:31

developer   ~0115699

I've written my own patch that also fixes the bug, along with a more extensive test to see how the implicit finally block interacts with explicit ones and also except blocks.

This is a little awkward because your patch does fix the bug, so I'm interested to know why you didn't upload it before.

Not to blow my own trumpet, but I want to say my patch is SLIGHTLY better because it's a little clearer as to what's going on, and it produces slightly more optimal code when it's the implicit finally block by itself:

From the if-statement that calls exit:

.Ll8:
    movq -8(%rbp),%rax
    cmpl $1,(%rax)
    je .Lj9
...

Your patch does the following:

.Lj9:
.Ll11:
    nop
.Lj8:
    movq %rbp,%rcx
    call P$TW34772$_$TEST1$array_of_LONGINT_$$_fin$00000001

While mine (and the trunk) does this:

.Lj17:
.Ll11:
    nop
.Lj8:
.Lj9:
    movq %rbp,%rcx
    call P$TW34772$_$TEST1$array_of_LONGINT_$$_fin$00000001

The jump is after the "nop" not before, so your code makes the final EXE very slightly more inefficient. I hope you don't take it personally.

tw34772.pp (12,098 bytes)
program tw34772;

{$mode objfpc}{$H+}
{$WARN 5058 off : Variable "$1" does not seem to be initialized}

uses
  Classes, SysUtils;


procedure Test1(a: array of Integer);
begin
  WriteLn('Test1 - Start ', a[0]);
  if a[0] = 1 then exit;
  if a[0] = 2 then raise EAbort.Create('Test');
  WriteLn('Test1 - End ', a[0]);
end;


procedure Test2(a: array of Integer);
var
  Test: Pointer;
begin
  GetMem(Test, 4);
  try
    WriteLn('Test2 - Start ', a[0]);
    if a[0] = 1 then exit;
    if a[0] = 2 then raise EAbort.Create('Test');
    WriteLn('Test2 - End ', a[0]);
  finally
    FreeMem(Test);
    WriteLn('Test2 - Finally ', a[0]);
  end;
end;


procedure Test3(a: array of Integer);
begin
  try
    WriteLn('Test3 - Start ', a[0]);
    if a[0] = 1 then exit;
    if a[0] = 2 then raise EAbort.Create('Test');
    WriteLn('Test3 - End ', a[0]);
  except
    on E: Exception do
      begin
        if E.ClassType <> EAbort then raise; { Unexpected exception }
        WriteLn('Test3 - Except ', a[0]);
      end;
  end;
end;


procedure Test4(a: array of Integer);
var
  Test: Pointer;
begin
  GetMem(Test, 4);
  try
    try
      WriteLn('Test4 - Start ', a[0]);
      if a[0] = 1 then exit;
      if a[0] = 2 then raise EAbort.Create('Test');
      WriteLn('Test4 - End ', a[0]);
    except
      on E: Exception do
        begin
          if E.ClassType <> EAbort then raise; { Unexpected exception }
          WriteLn('Test4 - Except ', a[0]);
        end;
    end;
  finally
    FreeMem(Test);
    WriteLn('Test4 - Finally ', a[0]);
  end;
end;


procedure Test5(a: array of Integer); safecall;
begin
  WriteLn('Test5 - Start ', a[0]);
  if a[0] = 1 then exit;
  if a[0] = 2 then raise EAbort.Create('Test');
  WriteLn('Test5 - End ', a[0]);
end;


procedure Test6(a: array of Integer); safecall;
var
  Test: Pointer;
begin
  GetMem(Test, 4);
  try
    WriteLn('Test6 - Start ', a[0]);
    if a[0] = 1 then exit;
    if a[0] = 2 then raise EAbort.Create('Test');
    WriteLn('Test6 - End ', a[0]);
  finally
    FreeMem(Test);
    WriteLn('Test6 - Finally ', a[0]);
  end;
end;


procedure Test7(a: array of Integer); safecall;
begin
  try
    WriteLn('Test7 - Start ', a[0]);
    if a[0] = 1 then exit;
    if a[0] = 2 then raise EAbort.Create('Test');
    WriteLn('Test7 - End ', a[0]);
  except
    on E: Exception do
      begin
        if E.ClassType <> EAbort then raise; { Unexpected exception }
        WriteLn('Test7 - Except ', a[0]);
      end;
  end;
end;


procedure Test8(a: array of Integer); safecall;
var
  Test: Pointer;
begin
  GetMem(Test, 4);
  try
    try
      WriteLn('Test8 - Start ', a[0]);
      if a[0] = 1 then exit;
      if a[0] = 2 then raise EAbort.Create('Test');
      WriteLn('Test8 - End ', a[0]);
    except
      on E: Exception do
        begin
          if E.ClassType <> EAbort then raise; { Unexpected exception }
          WriteLn('Test8 - Except ', a[0]);
        end;
    end;
  finally
    FreeMem(Test);
    WriteLn('Test8 - Finally ', a[0]);
  end;
end;


function Test9(a: array of Integer): Boolean;
var
  Test: Pointer;
begin
  Result := True;
  GetMem(Test, 4);
  try
    WriteLn('Test9 - Start ', a[0]);
    if a[0] = 1 then exit;
    if a[0] = 2 then raise EAbort.Create('Test');
    WriteLn('Test9 - End ', a[0]);
  finally
    FreeMem(Test);
    WriteLn('Test9 - Finally ', a[0]);
    if a[0] = 0 then Result := False;
  end;

  Result := True;

end;


procedure Test10(a: array of Integer);
var
  Test, Test2: Pointer;
begin
  GetMem(Test, 4);
  try
    GetMem(Test2, 4);
    try
      WriteLn('Test10 - Start ', a[0]);
      if a[0] = 1 then exit;
      if a[0] = 2 then raise EAbort.Create('Test');
      WriteLn('Test10 - End ', a[0]);
    finally
      FreeMem(Test2);
      WriteLn('Test10 - Finally A ', a[0]);
    end;
  finally
    FreeMem(Test);
    WriteLn('Test10 - Finally B ', a[0]);
  end;
end;


procedure Test11(a: array of Integer); safecall;
var
  Test, Test2: Pointer;
begin
  GetMem(Test, 4);
  try
    GetMem(Test2, 4);
    try
      WriteLn('Test11 - Start ', a[0]);
      if a[0] = 1 then exit;
      if a[0] = 2 then raise EAbort.Create('Test');
      WriteLn('Test11 - End ', a[0]);
    finally
      FreeMem(Test2);
      WriteLn('Test11 - Finally A ', a[0]);
    end;
  finally
    FreeMem(Test);
    WriteLn('Test11 - Finally B ', a[0]);
  end;
end;


procedure Test12(a: Integer); safecall;
var
  Test, Test2: Pointer;
begin
  GetMem(Test, 4);
  try
    GetMem(Test2, 4);
    try
      WriteLn('Test12 - Start ', a);
      if a = 1 then exit;
      if a = 2 then raise EAbort.Create('Test');
      WriteLn('Test12 - End ', a);
    finally
      FreeMem(Test2);
      WriteLn('Test12 - Finally A ', a);
    end;
  finally
    FreeMem(Test);
    WriteLn('Test12 - Finally B ', a);
  end;
end;


var
  X, TestCount: Integer;
  ReferenceCount: LongInt;
  MemMgr, NewMemMgr: TMemoryManager;
  Fail: Boolean;

function HookGetMem(Size: PtrUInt): Pointer;
  begin
    Inc(ReferenceCount);
    Result := MemMgr.GetMem(Size);
  end;

function HookReAllocMem(var p: Pointer; Size: PtrUInt): Pointer;
  begin
    if p = nil then
      Inc(ReferenceCount);

    Result := MemMgr.ReAllocMem(p, Size);

    { If ReAllocMem(nil, 0) is called, ReferenceCount is incremented then
      decremented, reflecting the null operation }
    if Size = 0 then
      Dec(ReferenceCount);
  end;

function HookFreeMem(ptr: Pointer): PtrUInt;
  begin
    Dec(ReferenceCount);
    Result := MemMgr.FreeMem(ptr);
  end;

function HookFreeMemSize(ptr: Pointer; Size: PtrUInt): PtrUInt;
  begin
    Dec(ReferenceCount);
    Result := MemMgr.FreeMemSize(ptr, Size);
  end;

procedure PostTestAnalysis;
  begin
    Inc(TestCount);
    if ReferenceCount <> 0 then
      begin
        WriteLn('FAIL - Reference count = ', ReferenceCount);
        Fail := True;
      end;
  end;

procedure CheckTestCount;
  begin
    if TestCount <> 3 then
      begin
        Fail := True;
        WriteLn('FAIL - Only ', TestCount, ' sub-tests were run for this test');
      end;
  end;

begin
  { Set up hooks to track memory leaks }
  GetMemoryManager(MemMgr);
  NewMemMgr := MemMgr;
  NewMemMgr.GetMem := @HookGetMem;
  NewMemMgr.ReAllocMem := @HookReAllocMem;
  NewMemMgr.FreeMem := @HookFreeMem;
  NewMemMgr.FreeMemSize := @HookFreeMemSize;
  SetMemoryManager(NewMemMgr);

  { Test parameters
    [0] = Run to end of procedure
    [1] = Exit prematurely
    [2] = raise exception
  }

  { Test1 - implicit try..finally }
  TestCount := 0;
  for X := 0 to 2 do
    begin
      ReferenceCount := 0;
      try
        Test1([X]);
      except
        on E: Exception do
          if E.ClassType <> EAbort then
            begin
              { Unexpected exception }
              WriteLn('FAIL - Exception ', E.ClassName, ' raised: "', E.Message, '"');
              Fail := True;
              Continue;
            end;
      end;

      PostTestAnalysis;
    end;

  CheckTestCount;

  { Test2 - implicit + explicit try..finally }
  TestCount := 0;
  for X := 0 to 2 do
    begin
      ReferenceCount := 0;
      try
        Test2([X]);
      except
        on E: Exception do
          if E.ClassType <> EAbort then
            begin
              { Unexpected exception }
              WriteLn('FAIL - Exception ', E.ClassName, ' raised: "', E.Message, '"');
              Fail := True;
              Continue;
            end;
      end;

      PostTestAnalysis;
    end;

  CheckTestCount;

  { Test3 - implicit try..finally and explicit try..except }
  TestCount := 0;
  for X := 0 to 2 do
    begin
      ReferenceCount := 0;
      try
        Test3([X]);
      except
        { Exceptions should be caught }
        on E: Exception do
          begin
            WriteLn('FAIL - Exception ', E.ClassName, ' raised: "', E.Message, '"');
            Fail := True;
            Continue;
          end;
      end;

      PostTestAnalysis;
    end;

  CheckTestCount;

  { Test4 - implicit + explicit try..finally and explicit try..except }
  TestCount := 0;
  for X := 0 to 2 do
    begin
      ReferenceCount := 0;
      try
        Test4([X]);
      except
        { Exceptions should be caught }
        on E: Exception do
          begin
            WriteLn('FAIL - Exception ', E.ClassName, ' raised: "', E.Message, '"');
            Fail := True;
            Continue;
          end;
      end;

      PostTestAnalysis;
    end;

  CheckTestCount;

  { Test5 - implicit try..finally with safecall }
  TestCount := 0;
  for X := 0 to 2 do
    begin
      ReferenceCount := 0;
      try
        Test5([X]);
      except
        { Everything gets wrapped into a ESafecallException }
      end;

      PostTestAnalysis;
    end;

  CheckTestCount;

  { Test6 - implicit + explicit try..finally with safecall }
  TestCount := 0;
  for X := 0 to 2 do
    begin
      ReferenceCount := 0;
      try
        Test6([X]);
      except
        { Everything gets wrapped into a ESafecallException }
      end;

      PostTestAnalysis;
    end;

  CheckTestCount;

  { Test7 - implicit try..finally and explicit try..except with safecall }
  TestCount := 0;
  for X := 0 to 2 do
    begin
      ReferenceCount := 0;
      try
        Test7([X]);
      except
        { Everything gets wrapped into a ESafecallException }
      end;

      PostTestAnalysis;
    end;

  CheckTestCount;

  { Test8 - implicit + explicit try..finally and explicit try..except with safecall }
  TestCount := 0;
  for X := 0 to 2 do
    begin
      ReferenceCount := 0;
      try
        Test8([X]);
      except
        { Everything gets wrapped into a ESafecallException }
      end;

      PostTestAnalysis;
    end;

  CheckTestCount;

  { Test9 - implicit + explicit try..finally with code following }
  TestCount := 0;
  for X := 0 to 2 do
    begin
      ReferenceCount := 0;
      try
        if not Test9([X]) then
          begin
            WriteLn('FAIL -  Code following finally block wasn''t executed');
            Fail := True;
            Continue;
          end;
      except
        on E: Exception do
          if E.ClassType <> EAbort then
            begin
              { Unexpected exception }
              WriteLn('FAIL - Exception ', E.ClassName, ' raised: "', E.Message, '"');
              Fail := True;
              Continue;
            end;
      end;

      PostTestAnalysis;
    end;

  CheckTestCount;

  { Test10 - implicit + 2 * explicit try..finally }
  TestCount := 0;
  for X := 0 to 2 do
    begin
      ReferenceCount := 0;
      try
        Test10([X]);
      except
        on E: Exception do
          if E.ClassType <> EAbort then
            begin
              { Unexpected exception }
              WriteLn('FAIL - Exception ', E.ClassName, ' raised: "', E.Message, '"');
              Fail := True;
              Continue;
            end;
      end;

      PostTestAnalysis;
    end;

  CheckTestCount;

  { Test11 - implicit + 2 * explicit try..finally with safecall }
  TestCount := 0;
  for X := 0 to 2 do
    begin
      ReferenceCount := 0;
      try
        Test11([X]);
      except
        { Everything gets wrapped into a ESafecallException }
      end;

      PostTestAnalysis;
    end;

  CheckTestCount;

  { Test12 - 2 * explicit try..finally with safecall }
  TestCount := 0;
  for X := 0 to 2 do
    begin
      ReferenceCount := 0;
      try
        Test12(X);
      except
        { Everything gets wrapped into a ESafecallException }
      end;

      PostTestAnalysis;
    end;

  CheckTestCount;

  if Fail then
    Halt(1)
  else
    WriteLn('ok');
end.
tw34772.pp (12,098 bytes)

J. Gareth Moreton

2019-04-21 04:33

developer   ~0115700

I believe the patch "i34772.patch" now fixes the issue. Can you confirm, Martin Friebe?

Sergei Gorelkin

2019-04-21 11:00

developer   ~0115702

I didn't upload the patch immediately after making it, because I was intending to fully test it and then apply it myself, without uploading here. Since I'm the author of Windows SEH support, fixing this bug was my responsibility :)

As for efficiency, putting the exitlabel before 'nop' (or, more precisely, at address before .Lj8) was exactly the goal of my patch. The exitlabel (.Lj9) residing at the same address as end of scope (.Lj8) was the reason of wrong behavior, because it considered the outer finalizer a part of inner 'try' part and executed it once during local_unwind, and then the second time during normal execution.
Another possible approach is placing the exitlabel after call to implicit finalizer (that probably is what your patch does, from the looks of it), so that both inner and outer finalizers are executed as part of unwind, but that will somewhat slow down execution of 'exit' statement, because runtime will have to interpret two unwind scopes instead of just one.

J. Gareth Moreton

2019-04-21 13:40

developer   ~0115704

One thought that sprung to mind as a future optimisation is to not call the unwind routine at all with Exit, but instead just call the finally blocks as regular procedures, since it's not in an error situation. Will that work or am I missing something?

Sergei Gorelkin

2019-04-21 14:20

developer   ~0115706

You may miss that 'finally' code is allowed to raise its own exceptions. Correctly handling them while executing 'exit' path outside of unwind may complicate code generation too much, if possible at all. Back when I was writing the SEH support, other compilers, namely Delphi and MSVC did not have such optimization.

J. Gareth Moreton

2019-04-21 16:04

developer   ~0115707

Last edited: 2019-04-22 14:13

View 3 revisions

Fair enough. Thanks!

Regarding my patch, the logic is that TrueExitLabel is set to the procedure's original exit label (since currExitLabel gets changed when it enters a new try block), and it is this that's passed into the unwind procedure as the parameter, whereas before, it was currExitLabel, which was set to the implicit finally block (or otherwise wasn't the true end point), which is also inside the unwind information, hence got called twice.

(Also, my patch is slightly more general-purpose in that if another platform introduces stack unwinding, additional plaform-specific code hopefully won't need to be written because of the TrueExitLabel introduction)

J. Gareth Moreton

2019-04-22 14:12

developer   ~0115726

Confirmed with Jonas that since Sergei is the maintainer of SEH functionality, the final call as to which patch should be applied is up to him.

Sergei, it's in your hands now!

J. Gareth Moreton

2019-05-15 14:45

developer   ~0116206

Any feedback on this? Either of the two patches fixes the problem, but until one of them is applied, the trunk compiler will generate bad code in the aforementioned instance.

Issue History

Date Modified Username Field Change
2018-12-28 14:21 Martin Friebe New Issue
2018-12-28 16:40 J. Gareth Moreton Priority normal => high
2018-12-28 16:40 J. Gareth Moreton Severity minor => crash
2018-12-28 17:11 Cyrax Note Added: 0112953
2018-12-28 17:13 Cyrax File Added: project1.zip
2018-12-28 17:15 Cyrax File Added: x86_64-win64_project1.s.zip
2018-12-28 17:16 Cyrax File Added: i386-win32_project1.s.zip
2018-12-28 17:56 Cyrax Note Added: 0112955
2018-12-28 18:06 Martin Friebe Note Added: 0112957
2018-12-28 22:54 Sergei Gorelkin Note Added: 0112966
2018-12-28 23:08 Sergei Gorelkin Note Edited: 0112966 View Revisions
2018-12-29 18:36 Bart Broersma Note Added: 0112985
2019-02-28 12:19 Snus Note Added: 0114500
2019-04-19 08:43 J. Gareth Moreton Assigned To => J. Gareth Moreton
2019-04-19 08:43 J. Gareth Moreton Status new => assigned
2019-04-19 14:37 Sergei Gorelkin File Added: nx64flw.pas.patch
2019-04-19 14:38 Sergei Gorelkin File Added: 34772.pas
2019-04-19 14:41 Sergei Gorelkin Note Added: 0115675
2019-04-19 14:51 J. Gareth Moreton Note Added: 0115676
2019-04-19 14:52 J. Gareth Moreton Note Edited: 0115676 View Revisions
2019-04-19 14:52 J. Gareth Moreton Note Edited: 0115676 View Revisions
2019-04-21 04:31 J. Gareth Moreton File Added: i34772.patch
2019-04-21 04:31 J. Gareth Moreton File Added: tw34772.pp
2019-04-21 04:31 J. Gareth Moreton Note Added: 0115699
2019-04-21 04:33 J. Gareth Moreton Assigned To J. Gareth Moreton => Martin Friebe
2019-04-21 04:33 J. Gareth Moreton Status assigned => feedback
2019-04-21 04:33 J. Gareth Moreton Note Added: 0115700
2019-04-21 11:00 Sergei Gorelkin Note Added: 0115702
2019-04-21 13:40 J. Gareth Moreton Note Added: 0115704
2019-04-21 14:20 Sergei Gorelkin Note Added: 0115706
2019-04-21 16:04 J. Gareth Moreton Note Added: 0115707
2019-04-21 18:31 J. Gareth Moreton Note Edited: 0115707 View Revisions
2019-04-22 14:10 J. Gareth Moreton Assigned To Martin Friebe => Sergei Gorelkin
2019-04-22 14:12 J. Gareth Moreton Status feedback => assigned
2019-04-22 14:12 J. Gareth Moreton Note Added: 0115726
2019-04-22 14:13 J. Gareth Moreton Note Edited: 0115707 View Revisions
2019-05-15 14:45 J. Gareth Moreton Note Added: 0116206