From 4dfc731bdccafc8f290f59e209dbcdc8ea9c473d Mon Sep 17 00:00:00 2001
From: Jonas Maebe <jonas@freepascal.org>
Date: Sun, 16 Mar 2014 19:46:17 +0000
Subject: [PATCH] + support for nested classes in the WPO devirtualisation
and VMT optimization infrastructure (mantis #25869)
git-svn-id: trunk@27167 -
---
.gitattributes | 1 +
compiler/optvirt.pas | 24 ++++++++++++++++--------
tests/webtbs/tw25869.pp | 17 +++++++++++++++++
3 files changed, 34 insertions(+), 8 deletions(-)
create mode 100644 tests/webtbs/tw25869.pp
diff --git a/.gitattributes b/.gitattributes
index ccc6efdb89..9da9f98e01 100644
--- a/.gitattributes
+++ b/.gitattributes
@@ -13851,6 +13851,7 @@ tests/webtbs/tw25603.pp svneol=native#text/pascal
tests/webtbs/tw2561.pp svneol=native#text/plain
tests/webtbs/tw25685.pp svneol=native#text/pascal
tests/webtbs/tw25814.pp svneol=native#text/plain
+tests/webtbs/tw25869.pp svneol=native#text/plain
tests/webtbs/tw2588.pp svneol=native#text/plain
tests/webtbs/tw2589.pp svneol=native#text/plain
tests/webtbs/tw2594.pp svneol=native#text/plain
diff --git a/compiler/optvirt.pas b/compiler/optvirt.pas
index 15fa7fc197..60922abb5f 100644
--- a/compiler/optvirt.pas
+++ b/compiler/optvirt.pas
@@ -579,10 +579,10 @@ unit optvirt;
{ helper routines: decompose an object & procdef combo into a unitname, class name and vmtentry number
(unit name where the objectdef is declared, class name of the objectdef, vmtentry number of the
procdef -- procdef does not necessarily belong to objectdef, it may also belong to a descendant
- or parent)
+ or parent). classprefix is set in case of nested classes.
}
- procedure defunitclassname(objdef: tobjectdef; out unitname, classname: pshortstring);
+ procedure defunitclassname(objdef: tobjectdef; out unitname, classname: pshortstring; out classprefix: shortstring);
const
mainprogname: string[2] = 'P$';
var
@@ -591,6 +591,12 @@ unit optvirt;
begin
objparentsymtab:=objdef.symtable;
mainsymtab:=objparentsymtab.defowner.owner;
+ classprefix:='';
+ while mainsymtab.symtabletype in [recordsymtable,objectsymtable] do
+ begin
+ classprefix:=mainsymtab.name^+'.'+classprefix;
+ mainsymtab:=mainsymtab.defowner.owner;
+ end;
{ main symtable must be static or global }
if not(mainsymtab.symtabletype in [staticsymtable,globalsymtable]) then
internalerror(200204177);
@@ -604,9 +610,9 @@ unit optvirt;
end;
- procedure defsdecompose(objdef: tobjectdef; procdef: tprocdef; out unitname, classname: pshortstring; out vmtentry: longint);
+ procedure defsdecompose(objdef: tobjectdef; procdef: tprocdef; out unitname, classname: pshortstring; out classprefix: shortstring; out vmtentry: longint);
begin
- defunitclassname(objdef,unitname,classname);
+ defunitclassname(objdef,unitname,classname,classprefix);
vmtentry:=procdef.extnumber;
{ if it's $ffff, this is not a valid virtual method }
if (vmtentry=$ffff) then
@@ -687,6 +693,7 @@ unit optvirt;
procedure tprogdevirtinfo.converttreenode(node: tinheritancetreenode; arg: pointer);
var
i: longint;
+ classprefix: shortstring;
unitid, classid: pshortstring;
unitdevirtinfo: tunitdevirtinfo;
classdevirtinfo: tclassdevirtinfo;
@@ -698,9 +705,9 @@ unit optvirt;
fill the vmt's of non-instantiated classes with calls to
FPC_ABSTRACTERROR during the optimisation phase
}
- defunitclassname(node.def,unitid,classid);
+ defunitclassname(node.def,unitid,classid,classprefix);
unitdevirtinfo:=addunitifnew(unitid^);
- classdevirtinfo:=unitdevirtinfo.addclass(classid^,node.instantiated);
+ classdevirtinfo:=unitdevirtinfo.addclass(classprefix+classid^,node.instantiated);
if (node.def.vmtentries.count=0) then
exit;
for i:=0 to node.def.vmtentries.count-1 do
@@ -1088,6 +1095,7 @@ unit optvirt;
classdevirtinfo: tclassdevirtinfo;
vmtentry: longint;
realobjdef: tobjectdef;
+ classprefix: shortstring;
begin
{ if we don't have any devirtualisation info, exit }
if not assigned(funits) then
@@ -1124,7 +1132,7 @@ unit optvirt;
end;
{ get the component names for the class/procdef combo }
- defsdecompose(realobjdef,tprocdef(procdef),unitid,classid,vmtentry);
+ defsdecompose(realobjdef,tprocdef(procdef),unitid,classid,classprefix,vmtentry);
{ If we don't have information about a particular unit/class/method,
it means that such class cannot be instantiated. So if we are
@@ -1143,7 +1151,7 @@ unit optvirt;
if not assigned(unitdevirtinfo) then
exit;
{ and for this class? }
- classdevirtinfo:=unitdevirtinfo.findclass(classid^);
+ classdevirtinfo:=unitdevirtinfo.findclass(classprefix+classid^);
if not assigned(classdevirtinfo) then
exit;
if forvmtentry and
diff --git a/tests/webtbs/tw25869.pp b/tests/webtbs/tw25869.pp
new file mode 100644
index 0000000000..ba0d218b8f
--- /dev/null
+++ b/tests/webtbs/tw25869.pp
@@ -0,0 +1,17 @@
+{ %wpoparas=optvmts }
+{ %wpopasses=1 }
+
+{$MODE OBJFPC}
+program test;
+
+type
+ TFoo = class
+ type
+ TSubFoo = class
+ end;
+ end;
+
+begin
+ TFoo.TSubFoo.Create();
+end.
+