From 0f06a7205b73ab8854f5b1093fd32d944854dbcd Mon Sep 17 00:00:00 2001 From: florian Date: Sun, 5 Apr 2020 16:26:10 +0000 Subject: [PATCH 1/2] * do not create full copies of objects when object checking is on, resolves #36863 git-svn-id: trunk@44598 - --- .gitattributes | 1 + compiler/nutils.pas | 23 ++++++++++++++++------- tests/webtbs/tw36863.pp | 30 ++++++++++++++++++++++++++++++ 3 files changed, 47 insertions(+), 7 deletions(-) create mode 100644 tests/webtbs/tw36863.pp diff --git a/.gitattributes b/.gitattributes index 6b4e2dcfce..a112040384 100644 --- a/.gitattributes +++ b/.gitattributes @@ -18136,6 +18136,7 @@ tests/webtbs/tw36738.pp svneol=native#text/pascal tests/webtbs/tw3676.pp svneol=native#text/plain tests/webtbs/tw3681.pp svneol=native#text/plain tests/webtbs/tw3683.pp svneol=native#text/plain +tests/webtbs/tw36863.pp svneol=native#text/pascal tests/webtbs/tw3687.pp svneol=native#text/plain tests/webtbs/tw3691.pp svneol=native#text/plain tests/webtbs/tw3694.pp svneol=native#text/plain diff --git a/compiler/nutils.pas b/compiler/nutils.pas index 1285d57b83..4f6a98b636 100644 --- a/compiler/nutils.pas +++ b/compiler/nutils.pas @@ -649,13 +649,21 @@ implementation block:=nil; stat:=nil; + self_temp:=nil; if docheck then begin { check for nil self-pointer } block:=internalstatements(stat); - self_temp:=ctempcreatenode.create_value( - self_resultdef,self_resultdef.size,tt_persistent,true, - self_node); + if is_object(self_resultdef) then + begin + self_temp:=ctempcreatenode.create_value( + cpointerdef.getreusable(self_resultdef),cpointerdef.getreusable(self_resultdef).size,tt_persistent,true, + caddrnode.create(self_node)); + end + else + self_temp:=ctempcreatenode.create_value( + self_resultdef,self_resultdef.size,tt_persistent,true, + self_node); addstatement(stat,self_temp); { in case of an object, self can only be nil if it's a dereferenced @@ -665,8 +673,6 @@ implementation (actualtargetnode(@self_node)^.nodetype=derefn) then begin check_self:=ctemprefnode.create(self_temp); - if is_object(self_resultdef) then - check_self:=caddrnode.create(check_self); addstatement(stat,cifnode.create( caddnode.create(equaln, ctypeconvnode.create_explicit( @@ -678,8 +684,10 @@ implementation nil) ); end; - addstatement(stat,ctempdeletenode.create_normal_temp(self_temp)); - self_node:=ctemprefnode.create(self_temp); + if is_object(self_resultdef) then + self_node:=cderefnode.create(ctemprefnode.create(self_temp)) + else + self_node:=ctemprefnode.create(self_temp) end; { in case of a classref, the "instance" is a pointer to pointer to a VMT and there is no vmt field } @@ -729,6 +737,7 @@ implementation ) ); addstatement(stat,ctempdeletenode.create_normal_temp(vmt_temp)); + addstatement(stat,ctempdeletenode.create(self_temp)); addstatement(stat,ctemprefnode.create(vmt_temp)); result:=block; end diff --git a/tests/webtbs/tw36863.pp b/tests/webtbs/tw36863.pp new file mode 100644 index 0000000000..459991d23f --- /dev/null +++ b/tests/webtbs/tw36863.pp @@ -0,0 +1,30 @@ +{ %OPT=-Ct -CR } +{$M 65536,65536} + +type + TObj = object + v: array [0..$2000] of Byte; + procedure Proc(depth: Integer); + procedure VProc; virtual; + end; + + procedure TObj.VProc; + begin + end; + + procedure TObj.Proc(depth: Integer); + begin + {stack is eaten here on the function entry} + if (depth < 64) then + Proc(depth+1); + {do not actually call the method since the obj is not initialized, just for minimal demonstration} + if (depth < 0) then + VProc; + end; + +var + Obj: TObj; +begin + Obj.Proc(0); + writeln('Completed'); +end. From 2f5d51436e4edfe944a9e5b276b564f63688f3b1 Mon Sep 17 00:00:00 2001 From: florian Date: Sun, 5 Apr 2020 16:26:11 +0000 Subject: [PATCH 2/2] + with the randseed set as in the test, the test fails on x86_64-linux, added so it won't be forgotten git-svn-id: trunk@44599 - --- .gitattributes | 1 + tests/webtbs/tw14315b.pp | 46 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 47 insertions(+) create mode 100644 tests/webtbs/tw14315b.pp diff --git a/.gitattributes b/.gitattributes index a112040384..19f7ce48f0 100644 --- a/.gitattributes +++ b/.gitattributes @@ -16835,6 +16835,7 @@ tests/webtbs/tw14236.pp svneol=native#text/plain tests/webtbs/tw1430.pp svneol=native#text/plain tests/webtbs/tw14307.pp svneol=native#text/plain tests/webtbs/tw14315.pp svneol=native#text/plain +tests/webtbs/tw14315b.pp svneol=native#text/pascal tests/webtbs/tw1433.pp svneol=native#text/plain tests/webtbs/tw14347.pp svneol=native#text/pascal tests/webtbs/tw14363.pp svneol=native#text/plain diff --git a/tests/webtbs/tw14315b.pp b/tests/webtbs/tw14315b.pp new file mode 100644 index 0000000000..97658b5a67 --- /dev/null +++ b/tests/webtbs/tw14315b.pp @@ -0,0 +1,46 @@ +program Project1; + +{$mode objfpc}{$H+} + +uses + Classes, SysUtils; + +function RandomRange(const low : longint; + const high : longint) : longint; +begin + if (high < low) then + result := high + random(low - high + 1) + else + Result := low + random(high - low + 1); +end; + +procedure GetStats(out used: ptruint); +var + fpcHeapStatus : TFPCHeapStatus; +begin + fpcHeapStatus := GetFPCHeapStatus(); + used:=fpcHeapStatus.CurrHeapUsed; + writeln(' heap status: cu=' + + IntToStr(fpcHeapStatus.CurrHeapUsed) + ', cs=' + + IntToStr(fpcHeapStatus.CurrHeapSize) + ', cf=' + + IntToStr(fpcHeapStatus.CurrHeapFree) + ', mu=' + + IntToStr(fpcHeapStatus.MaxHeapUsed) + ', ms=' + + IntToStr(fpcHeapStatus.MaxHeapSize)); +end; + +var + i : integer; + a : array of byte; + u1, u2: ptruint; +begin + randseed:=1586103426; + writeln('randseed: ',randseed); + GetStats(u1); + for i := 0 to 50 do begin + SetLength(a, RandomRange(1024,1024*1024*15)); + end; + SetLength(a, 0); + GetStats(u2); + if u1<>u2 then + halt(1); +end.