paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-07 18:47:52 +02:00
Code Issues Packages Projects Releases Wiki Activity

Merged revision(s) 42673, 47066, 47070 from trunk:

Browse Source 
* 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.

........
  * patch by J. Gareth Moreton: propagate exit use in nested try...except statements,
    resolves #35841
........
  * fix #35841 also for break and continue
........

git-svn-id: branches/fixes_3_2@47589 -
This commit is contained in:
svenbarth 2020-11-25 22:20:21 +00:00
parent 92a580d3a6
commit 63e2259556
4 changed files with 647 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitattributes vendored
View File

@ -17621,6 +17621,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/tw34848.pp svneol=native#text/pascal
@ -17660,6 +17661,7 @@ tests/webtbs/tw3577.pp svneol=native#text/plain
tests/webtbs/tw3578.pp svneol=native#text/plain
tests/webtbs/tw3579.pp svneol=native#text/plain
tests/webtbs/tw3583.pp svneol=native#text/plain
tests/webtbs/tw35841.pp svneol=native#text/pascal
tests/webtbs/tw35862.pp svneol=native#text/pascal
tests/webtbs/tw3589.pp svneol=native#text/plain
tests/webtbs/tw3594.pp svneol=native#text/plain

53
compiler/x86_64/nx64flw.pas
View File

@ -225,6 +225,7 @@ procedure tx64tryfinallynode.pass_generate_code;
endtrylabel,
finallylabel,
endfinallylabel,
templabel,
oldexitlabel: tasmlabel;
oldflowcontrol: tflowcontrol;
catch_frame: boolean;
@ -246,6 +247,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);
@ -286,20 +288,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;
@ -307,10 +308,24 @@ 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;
{ i32913 - if the try..finally block is also inside a try..finally or
try..except block, make a note of any Exit calls so all necessary labels
are generated. [Kit] }
if ((flowcontrol*[fc_exit,fc_break,fc_continue])<>[]) and (fc_inflowcontrol in oldflowcontrol) then
oldflowcontrol:=oldflowcontrol+(flowcontrol*[fc_exit,fc_break,fc_continue]);
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);
@ -419,6 +434,12 @@ procedure tx64tryexceptnode.pass_generate_code;
current_procinfo.CurrBreakLabel:=breakexceptlabel;
end;
{ i32913 - if the try..finally block is also inside a try..finally or
try..except block, make a note of any Exit calls so all necessary labels
are generated. [Kit] }
if ((flowcontrol*[fc_exit,fc_break,fc_continue])<>[]) and (fc_inflowcontrol in oldflowcontrol) then
oldflowcontrol:=oldflowcontrol+(flowcontrol*[fc_exit,fc_break,fc_continue]);
flowcontrol:=[fc_inflowcontrol];
{ on statements }
if assigned(right) then
@ -507,6 +528,12 @@ errorexit:
{ restore all saved labels }
endexceptlabel:=oldendexceptlabel;
{ i32913 - if the try..finally block is also inside a try..finally or
try..except block, make a note of any Exit calls so all necessary labels
are generated. [Kit] }
if ((flowcontrol*[fc_exit,fc_break,fc_continue])<>[]) and (fc_inflowcontrol in oldflowcontrol) then
oldflowcontrol:=oldflowcontrol+(flowcontrol*[fc_exit,fc_break,fc_continue]);
{ restore the control flow labels }
current_procinfo.CurrExitLabel:=oldCurrExitLabel;
if assigned(oldBreakLabel) then

551
tests/webtbs/tw34772.pp Normal file
View File

@ -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.

54
tests/webtbs/tw35841.pp Normal file
View File

@ -0,0 +1,54 @@
{ %norun }
{$mode objfpc}
procedure p1;
begin
try
writeln;
except
try
writeln;
Exit;
finally
writeln;
end;
end;
end;
procedure p2;
var
i : longint;
begin
for i:=1 to 10 do
try
writeln;
except
try
writeln;
break;
finally
writeln;
end;
end;
end;
procedure p3;
var
i : longint;
begin
for i:=1 to 10 do
try
writeln;
except
try
writeln;
continue;
finally
writeln;
end;
end;
end;
begin
end.