* x86_64: Fixed code generation for try..finally blocks, so that exit label from inner try..finally stays within scope of procedure's implicit try..finally block if one is present. Mantis #34772.

git-svn-id: trunk@42673 -

.gitattributes

@@ -17730,6 +17730,7 @@ tests/webtbs/tw3467.pp svneol=native#text/plain
 tests/webtbs/tw3470.pp svneol=native#text/plain
 tests/webtbs/tw3474.pp svneol=native#text/plain
 tests/webtbs/tw3477.pp svneol=native#text/plain
+tests/webtbs/tw34772.pp svneol=native#text/pascal
 tests/webtbs/tw3478.pp svneol=native#text/plain
 tests/webtbs/tw3479.pp svneol=native#text/plain
 tests/webtbs/tw34818.pp svneol=native#text/pascal

compiler/x86_64/nx64flw.pas

@@ -227,6 +227,7 @@ procedure tx64tryfinallynode.pass_generate_code;
     endtrylabel,
     finallylabel,
     endfinallylabel,
+    templabel,
     oldexitlabel: tasmlabel;
     oldflowcontrol: tflowcontrol;
     catch_frame: boolean;
@@ -248,6 +249,7 @@ procedure tx64tryfinallynode.pass_generate_code;
     oldflowcontrol:=flowcontrol;
     flowcontrol:=[fc_inflowcontrol];
 
+    templabel:=nil;
     current_asmdata.getjumplabel(trylabel);
     current_asmdata.getjumplabel(endtrylabel);
     current_asmdata.getjumplabel(finallylabel);
@@ -288,20 +290,19 @@ procedure tx64tryfinallynode.pass_generate_code;
           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. }
+    { 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
       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;
@@ -309,10 +310,18 @@ procedure tx64tryfinallynode.pass_generate_code;
           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);

tests/webtbs/tw34772.pp

@@ -0,0 +1,551 @@
+{ %target=win64 }
+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.