paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-17 13:39:36 +02:00
Code Issues Packages Projects Releases Wiki Activity

+ keep track of called virtual methods per unit. -Owoptvtms will now replace

Browse Source 
vmt entries of virtual methods that can never be called with references
    to FPC_ABSTRACTERROR. Some virtual methods are always considered to be
    reachable: published methods, and methods used as getter/setter for a
    published property.

git-svn-id: trunk@13238 -
This commit is contained in:
Jonas Maebe 2009-06-06 08:24:36 +00:00
parent 91ae3e8788
commit 41acad1d11
10 changed files with 509 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -8009,6 +8009,7 @@ tests/test/opt/twpo2.pp svneol=native#text/plain
tests/test/opt/twpo3.pp svneol=native#text/plain
tests/test/opt/twpo4.pp svneol=native#text/plain
tests/test/opt/twpo5.pp svneol=native#text/plain
tests/test/opt/twpo7.pp svneol=native#text/plain
tests/test/opt/uwpo2.pp svneol=native#text/plain
tests/test/packages/fcl-base/tascii85.pp svneol=native#text/plain
tests/test/packages/fcl-base/tgettext1.pp svneol=native#text/plain

123
compiler/cclasses.pas
View File

@ -504,6 +504,35 @@ type
end;
{******************************************************************
tbitset
*******************************************************************}
tbitset = class
private
fdata: pbyte;
fdatasize: longint;
public
constructor create(initsize: longint);
constructor create_bytesize(bytesize: longint);
destructor destroy; override;
procedure clear;
procedure grow(nsize: longint);
{ sets a bit }
procedure include(index: longint);
{ clears a bit }
procedure exclude(index: longint);
{ finds an entry, creates one if not exists }
function isset(index: longint): boolean;
procedure addset(aset: tbitset);
procedure subset(aset: tbitset);
property data: pbyte read fdata;
property datasize: longint read fdatasize;
end;
function FPHash(const s:shortstring):LongWord;
function FPHash(P: PChar; Len: Integer): LongWord;
@ -2757,4 +2786,98 @@ end;
Result := False;
end;
{****************************************************************************
tbitset
****************************************************************************}
constructor tbitset.create(initsize: longint);
begin
create_bytesize((initsize+7) div 8);
end;
constructor tbitset.create_bytesize(bytesize: longint);
begin
fdatasize:=bytesize;
getmem(fdata,fdataSize);
clear;
end;
destructor tbitset.destroy;
begin
freemem(fdata,fdatasize);
inherited destroy;
end;
procedure tbitset.clear;
begin
fillchar(fdata^,fdatasize,0);
end;
procedure tbitset.grow(nsize: longint);
begin
reallocmem(fdata,nsize);
fillchar(fdata[fdatasize],nsize-fdatasize,0);
fdatasize:=nsize;
end;
procedure tbitset.include(index: longint);
var
dataindex: longint;
begin
{ don't use bitpacked array, not endian-safe }
dataindex:=index shr 3;
if (dataindex>=datasize) then
grow(dataindex);
fdata[dataindex]:=fdata[dataindex] or (1 shl (index and 7));
end;
procedure tbitset.exclude(index: longint);
var
dataindex: longint;
begin
dataindex:=index shr 3;
if (dataindex>=datasize) then
exit;
fdata[dataindex]:=fdata[dataindex] and not(1 shl (index and 7));
end;
function tbitset.isset(index: longint): boolean;
var
dataindex: longint;
begin
dataindex:=index shr 3;
result:=
(dataindex<datasize) and
(((fdata[index shr 3] shr (index and 7)) and 1)<>0);
end;
procedure tbitset.addset(aset: tbitset);
var
i: longint;
begin
if (aset.datasize>datasize) then
grow(aset.datasize);
for i:=0 to aset.datasize-1 do
fdata[i]:=fdata[i] or aset.data[i];
end;
procedure tbitset.subset(aset: tbitset);
var
i: longint;
begin
for i:=0 to min(datasize,aset.datasize)-1 do
fdata[i]:=fdata[i] and not(aset.data[i]);
end;
end.

13
compiler/ncgld.pas
View File

@ -64,7 +64,8 @@ implementation
cpubase,parabase,
tgobj,ncgutil,
cgobj,
ncgbas,ncgflw;
ncgbas,ncgflw,
wpobase;
{*****************************************************************************
SSA (for memory temps) support
@ -481,6 +482,16 @@ implementation
if (po_virtualmethod in procdef.procoptions) and
not(nf_inherited in flags) then
begin
if (not assigned(current_procinfo) or
wpoinfomanager.symbol_live(current_procinfo.procdef.mangledname)) then
procdef._class.register_vmt_call(procdef.extnumber);
{$ifdef vtentry}
if not is_interface(procdef._class) then
begin
inc(current_asmdata.NextVTEntryNr);
current_asmdata.CurrAsmList.Concat(tai_symbol.CreateName('VTREF'+tostr(current_asmdata.NextVTEntryNr)+'_'+procdef._class.vmt_mangledname+'$$'+tostr(vmtoffset div sizeof(pint)),AT_FUNCTION,0));
end;
{$endif vtentry}
{ a classrefdef already points to the VMT }
if (left.resultdef.typ<>classrefdef) then
begin

9
compiler/ncgrtti.pas
View File

@ -67,7 +67,8 @@ implementation
fmodule,
symsym,
aasmtai,aasmdata,
defutil
defutil,
wpobase
;
@ -311,6 +312,12 @@ implementation
{ virtual method, write vmt offset }
current_asmdata.asmlists[al_rtti].concat(Tai_const.create(aitconst_ptr,
tprocdef(propaccesslist.procdef)._class.vmtmethodoffset(tprocdef(propaccesslist.procdef).extnumber)));
{ register for wpo }
tprocdef(propaccesslist.procdef)._class.register_vmt_call(tprocdef(propaccesslist.procdef).extnumber);
{$ifdef vtentry}
{ not sure if we can insert those vtentry symbols safely here }
{$error register methods used for published properties}
{$endif vtentry}
typvalue:=2;
end;
end;

141
compiler/optvirt.pas
View File

@ -40,6 +40,7 @@ unit optvirt;
fdef: tobjectdef;
fparent: tinheritancetreenode;
fchilds: tfpobjectlist;
fcalledvmtmethods: tbitset;
finstantiated: boolean;
function getchild(index: longint): tinheritancetreenode;
@ -57,6 +58,7 @@ unit optvirt;
this def (either new or existing one
}
function maybeaddchild(_def: tobjectdef; _instantiated: boolean): tinheritancetreenode;
function findchild(_def: tobjectdef): tinheritancetreenode;
end;
@ -73,6 +75,9 @@ unit optvirt;
function registerinstantiatedobjectdefrecursive(def: tobjectdef; instantiated: boolean): tinheritancetreenode;
procedure markvmethods(node: tinheritancetreenode; p: pointer);
procedure printobjectvmtinfo(node: tinheritancetreenode; arg: pointer);
procedure addcalledvmtentries(node: tinheritancetreenode; arg: pointer);
function getnodefordef(def: tobjectdef): tinheritancetreenode;
public
constructor create;
destructor destroy; override;
@ -81,6 +86,7 @@ unit optvirt;
}
procedure registerinstantiatedobjdef(def: tdef);
procedure registerinstantiatedclassrefdef(def: tdef);
procedure registercalledvmtentries(entries: tcalledvmtentries);
procedure checkforclassrefinheritance(def: tdef);
procedure foreachnode(proctocall: tinheritancetreecallback; arg: pointer);
procedure foreachleafnode(proctocall: tinheritancetreecallback; arg: pointer);
@ -178,6 +184,8 @@ unit optvirt;
fparent:=_parent;
fdef:=_def;
finstantiated:=_instantiated;
if assigned(_def) then
fcalledvmtmethods:=tbitset.create(_def.vmtentries.count);
end;
@ -185,6 +193,7 @@ unit optvirt;
begin
{ fchilds owns its members, so it will free them too }
fchilds.free;
fcalledvmtmethods.free;
inherited destroy;
end;
@ -211,8 +220,6 @@ unit optvirt;
function tinheritancetreenode.maybeaddchild(_def: tobjectdef; _instantiated: boolean): tinheritancetreenode;
var
i: longint;
begin
{ sanity check }
if assigned(_def.childof) then
@ -226,19 +233,32 @@ unit optvirt;
if not assigned(fchilds) then
fchilds:=tfpobjectlist.create(true);
{ def already a child -> return }
for i := 0 to fchilds.count-1 do
if (tinheritancetreenode(fchilds[i]).def=_def) then
begin
result:=tinheritancetreenode(fchilds[i]);
result.finstantiated:=result.finstantiated or _instantiated;
exit;
end;
{ not found, add new child }
result:=tinheritancetreenode.create(self,_def,_instantiated);
fchilds.add(result);
result:=findchild(_def);
if assigned(result) then
result.finstantiated:=result.finstantiated or _instantiated
else
begin
{ not found, add new child }
result:=tinheritancetreenode.create(self,_def,_instantiated);
fchilds.add(result);
end;
end;
function tinheritancetreenode.findchild(_def: tobjectdef): tinheritancetreenode;
var
i: longint;
begin
result:=nil;
if assigned(fchilds) then
for i := 0 to fchilds.count-1 do
if (tinheritancetreenode(fchilds[i]).def=_def) then
begin
result:=tinheritancetreenode(fchilds[i]);
break;
end;
end;
{ *************************** tinheritancetree ************************* }
constructor tinheritancetree.create;
@ -296,6 +316,37 @@ unit optvirt;
end;
function tinheritancetree.getnodefordef(def: tobjectdef): tinheritancetreenode;
begin
if assigned(def.childof) then
begin
result:=getnodefordef(def.childof);
if assigned(result) then
result:=result.findchild(def);
end
else
result:=froots.findchild(def);
end;
procedure tinheritancetree.registercalledvmtentries(entries: tcalledvmtentries);
var
node: tinheritancetreenode;
begin
node:=getnodefordef(tobjectdef(entries.objdef));
{ it's possible that no instance of this class or its descendants are
instantiated
}
if not assigned(node) then
exit;
{ now mark these methods as (potentially) called for this type and for
all of its descendants
}
addcalledvmtentries(node,entries.calledentries);
foreachnodefromroot(node,@addcalledvmtentries,entries.calledentries);
end;
procedure tinheritancetree.checkforclassrefinheritance(def: tdef);
var
i: longint;
@ -408,8 +459,19 @@ unit optvirt;
if not assigned(currnode.def.vmcallstaticinfo) then
currnode.def.vmcallstaticinfo:=allocmem(currnode.def.vmtentries.count*sizeof(tvmcallstatic));
{ if this method cannot be called, we can just mark it as
unreachable. This will cause its static name to be set to
FPC_ABSTRACTERROR later on. Exception: published methods are
always reachable (via RTTI).
}
if (pd.visibility<>vis_published) and
not(currnode.fcalledvmtmethods.isset(i)) then
begin
currnode.def.vmcallstaticinfo^[i]:=vmcs_unreachable;
currnode:=currnode.parent;
end
{ same procdef as in all instantiated childs? (yes or don't know) }
if (currnode.def.vmcallstaticinfo^[i] in [vmcs_default,vmcs_yes]) then
else if (currnode.def.vmcallstaticinfo^[i] in [vmcs_default,vmcs_yes]) then
begin
{ methods in uninstantiated classes can be made static if
they are the same in all instantiated derived classes
@ -439,14 +501,16 @@ unit optvirt;
end;
currnode:=currnode.parent;
end
else
else if (currnode.def.vmcallstaticinfo^[i]=vmcs_no) then
begin
{$IFDEF DEBUG_DEVIRT}
writeln(' not processing parents, already non-static for ',currnode.def.typename);
{$ENDIF}
{ parents are already set to vmcs_no, so no need to continue }
currnode:=nil;
end;
end
else
currnode:=currnode.parent;
until not assigned(currnode) or
not assigned(currnode.def);
end;
@ -463,10 +527,12 @@ unit optvirt;
var
i,
totaldevirtualised,
totalvirtual: ptrint;
totalvirtual,
totalunreachable: ptrint;
begin
totaldevirtualised:=0;
totalvirtual:=0;
totalunreachable:=0;
writeln(node.def.typename);
if (node.def.vmtentries.count=0) then
begin
@ -481,13 +547,26 @@ unit optvirt;
begin
inc(totaldevirtualised);
writeln(' Devirtualised: ',pvmtentry(node.def.vmtentries[i])^.procdef.typename);
end
else if (node.def.vmcallstaticinfo^[i]=vmcs_unreachable) then
begin
inc(totalunreachable);
writeln(' Unreachable: ',pvmtentry(node.def.vmtentries[i])^.procdef.typename);
end;
end;
writeln('Total devirtualised: ',totaldevirtualised,'/',totalvirtual);
writeln('Total devirtualised/unreachable/all: ',totaldevirtualised,'/',totalunreachable,'/',totalvirtual);
writeln;
end;
procedure tinheritancetree.addcalledvmtentries(node: tinheritancetreenode; arg: pointer);
var
vmtentries: tbitset absolute arg;
begin
node.fcalledvmtmethods.addset(vmtentries);
end;
procedure tinheritancetree.printvmtinfo;
begin
foreachnode(@printobjectvmtinfo,nil);
@ -622,11 +701,18 @@ unit optvirt;
if (node.def.vmtentries.count=0) then
exit;
for i:=0 to node.def.vmtentries.count-1 do
if (po_virtualmethod in pvmtentry(node.def.vmtentries[i])^.procdef.procoptions) and
(node.def.vmcallstaticinfo^[i]=vmcs_yes) then
begin
{ add info about devirtualised vmt entry }
classdevirtinfo.addstaticmethod(i,pvmtentry(node.def.vmtentries[i])^.procdef.mangledname);
if (po_virtualmethod in pvmtentry(node.def.vmtentries[i])^.procdef.procoptions) then
case node.def.vmcallstaticinfo^[i] of
vmcs_yes:
begin
{ add info about devirtualised vmt entry }
classdevirtinfo.addstaticmethod(i,pvmtentry(node.def.vmtentries[i])^.procdef.mangledname);
end;
vmcs_unreachable:
begin
{ static reference to FPC_ABSTRACTERROR }
classdevirtinfo.addstaticmethod(i,'FPC_ABSTRACTERROR');
end;
end;
end;
@ -809,6 +895,17 @@ unit optvirt;
end;
end;
{ add info about called virtual methods }
hp:=tmodule(loaded_units.first);
while assigned(hp) do
begin
if assigned(hp.wpoinfo.calledvmtentries) then
for i:=0 to hp.wpoinfo.calledvmtentries.count-1 do
inheritancetree.registercalledvmtentries(tcalledvmtentries(hp.wpoinfo.calledvmtentries[i]));
hp:=tmodule(hp.next);
end;
inheritancetree.optimizevirtualmethods;
{$ifdef DEBUG_DEVIRT}
inheritancetree.printvmtinfo;

2
compiler/ppu.pas
View File

@ -43,7 +43,7 @@ type
{$endif Test_Double_checksum}
const
CurrentPPUVersion = 97;
CurrentPPUVersion = 98;
{ buffer sizes }
maxentrysize = 1024;

12
compiler/symdef.pas
View File

@ -231,7 +231,7 @@ interface
{ tobjectdef }
tvmcallstatic = (vmcs_default, vmcs_yes, vmcs_no);
tvmcallstatic = (vmcs_default, vmcs_yes, vmcs_no, vmcs_unreachable);
pmvcallstaticinfo = ^tmvcallstaticinfo;
tmvcallstaticinfo = array[0..1024*1024-1] of tvmcallstatic;
tobjectdef = class(tabstractrecorddef)
@ -296,9 +296,11 @@ interface
function FindDestructor : tprocdef;
function implements_any_interfaces: boolean;
procedure reset; override;
{ WPO }
procedure register_created_object_type;override;
procedure register_maybe_created_object_type;
procedure register_created_classref_type;
procedure register_vmt_call(index:longint);
end;
tclassrefdef = class(tabstractpointerdef)
@ -4286,6 +4288,14 @@ implementation
end;
end;
procedure tobjectdef.register_vmt_call(index: longint);
begin
if (is_object(self) or is_class(self)) then
current_module.wpoinfo.addcalledvmtentry(self,index);
end;
{****************************************************************************
TImplementedInterface
****************************************************************************}

119
compiler/wpobase.pas
View File

@ -110,6 +110,31 @@ type
{ ** Information created per unit for use during subsequent compilation *** }
{ ************************************************************************* }
{ information about called vmt entries for a class }
tcalledvmtentries = class
protected
{ the class }
fobjdef: tdef;
fobjdefderef: tderef;
{ the vmt entries }
fcalledentries: tbitset;
public
constructor create(_objdef: tdef; nentries: longint);
constructor ppuload(ppufile: tcompilerppufile);
destructor destroy; override;
procedure ppuwrite(ppufile: tcompilerppufile);
procedure buildderef;
procedure buildderefimpl;
procedure deref;
procedure derefimpl;
property objdef: tdef read fobjdef write fobjdef;
property objdefderef: tderef read fobjdefderef write fobjdefderef;
property calledentries: tbitset read fcalledentries write fcalledentries;
end;
{ base class of information collected per unit. Still needs to be
generalised for different kinds of wpo information, currently specific
to devirtualization.
@ -127,6 +152,12 @@ type
so they can end up in a classrefdef var and be instantiated)
}
fmaybecreatedbyclassrefdeftypes: tfpobjectlist;
{ called virtual methods for all classes (hashed by mangled classname,
entries bitmaps indicating which vmt entries per class are called --
tcalledvmtentries)
}
fcalledvmtentries: tfphashlist;
public
constructor create; reintroduce; virtual;
destructor destroy; override;
@ -134,10 +165,12 @@ type
property createdobjtypes: tfpobjectlist read fcreatedobjtypes;
property createdclassrefobjtypes: tfpobjectlist read fcreatedclassrefobjtypes;
property maybecreatedbyclassrefdeftypes: tfpobjectlist read fmaybecreatedbyclassrefdeftypes;
property calledvmtentries: tfphashlist read fcalledvmtentries;
procedure addcreatedobjtype(def: tdef);
procedure addcreatedobjtypeforclassref(def: tdef);
procedure addmaybecreatedbyclassref(def: tdef);
procedure addcalledvmtentry(def: tdef; index: longint);
end;
{ ************************************************************************* }
@ -321,10 +354,13 @@ implementation
fcreatedobjtypes:=tfpobjectlist.create(false);
fcreatedclassrefobjtypes:=tfpobjectlist.create(false);
fmaybecreatedbyclassrefdeftypes:=tfpobjectlist.create(false);
fcalledvmtentries:=tfphashlist.create;
end;
destructor tunitwpoinfobase.destroy;
var
i: longint;
begin
fcreatedobjtypes.free;
fcreatedobjtypes:=nil;
@ -332,6 +368,12 @@ implementation
fcreatedclassrefobjtypes:=nil;
fmaybecreatedbyclassrefdeftypes.free;
fmaybecreatedbyclassrefdeftypes:=nil;
for i:=0 to fcalledvmtentries.count-1 do
tcalledvmtentries(fcalledvmtentries[i]).free;
fcalledvmtentries.free;
fcalledvmtentries:=nil;
inherited destroy;
end;
@ -341,16 +383,35 @@ implementation
fcreatedobjtypes.add(def);
end;
procedure tunitwpoinfobase.addcreatedobjtypeforclassref(def: tdef);
begin
fcreatedclassrefobjtypes.add(def);
end;
procedure tunitwpoinfobase.addmaybecreatedbyclassref(def: tdef);
begin
fmaybecreatedbyclassrefdeftypes.add(def);
end;
procedure tunitwpoinfobase.addcalledvmtentry(def: tdef; index: longint);
var
entries: tcalledvmtentries;
key: shortstring;
begin
key:=tobjectdef(def).vmt_mangledname;
entries:=tcalledvmtentries(fcalledvmtentries.find(key));
if not assigned(entries) then
begin
entries:=tcalledvmtentries.create(def,tobjectdef(def).vmtentries.count);
fcalledvmtentries.add(key,entries);
end;
entries.calledentries.include(index);
end;
{ twpofilereader }
function twpofilereader.getnextnoncommentline(out s: string):
@ -677,4 +738,62 @@ implementation
inherited destroy;
end;
{ tcalledvmtentries }
constructor tcalledvmtentries.create(_objdef: tdef; nentries: longint);
begin
objdef:=_objdef;
calledentries:=tbitset.create(nentries);
end;
constructor tcalledvmtentries.ppuload(ppufile: tcompilerppufile);
var
len: longint;
begin
ppufile.getderef(fobjdefderef);
len:=ppufile.getlongint;
calledentries:=tbitset.create_bytesize(len);
if (len <> calledentries.datasize) then
internalerror(2009060301);
ppufile.readdata(calledentries.data^,len);
end;
destructor tcalledvmtentries.destroy;
begin
fcalledentries.free;
inherited destroy;
end;
procedure tcalledvmtentries.ppuwrite(ppufile: tcompilerppufile);
begin
ppufile.putderef(objdefderef);
ppufile.putlongint(calledentries.datasize);
ppufile.putdata(calledentries.data^,calledentries.datasize);
end;
procedure tcalledvmtentries.buildderef;
begin
objdefderef.build(objdef);
end;
procedure tcalledvmtentries.buildderefimpl;
begin
end;
procedure tcalledvmtentries.deref;
begin
objdef:=tdef(objdefderef.resolve);
end;
procedure tcalledvmtentries.derefimpl;
begin
end;
end.

41
compiler/wpoinfo.pas
View File

@ -41,6 +41,7 @@ type
fcreatedobjtypesderefs: pderefarray;
fcreatedclassrefobjtypesderefs: pderefarray;
fmaybecreatedbyclassrefdeftypesderefs: pderefarray;
fcalledvmtentriestemplist: tfpobjectlist;
{ devirtualisation information -- end }
public
@ -92,6 +93,13 @@ implementation
freemem(fmaybecreatedbyclassrefdeftypesderefs);
fmaybecreatedbyclassrefdeftypesderefs:=nil;
end;
if assigned(fcalledvmtentriestemplist) then
begin
fcalledvmtentriestemplist.free;
fcalledvmtentriestemplist:=nil;
end;
inherited destroy;
end;
@ -113,6 +121,10 @@ implementation
for i:=0 to fmaybecreatedbyclassrefdeftypes.count-1 do
ppufile.putderef(fmaybecreatedbyclassrefdeftypesderefs^[i]);
ppufile.putlongint(fcalledvmtentries.count);
for i:=0 to fcalledvmtentries.count-1 do
tcalledvmtentries(fcalledvmtentries[i]).ppuwrite(ppufile);
ppufile.writeentry(ibcreatedobjtypes);
{ don't free deref arrays immediately after use, as the types may need
@ -149,6 +161,13 @@ implementation
getmem(fmaybecreatedbyclassrefdeftypesderefs,len*sizeof(tderef));
for i:=0 to len-1 do
ppufile.getderef(fmaybecreatedbyclassrefdeftypesderefs^[i]);
len:=ppufile.getlongint;
fcalledvmtentriestemplist:=tfpobjectlist.create(false);
fcalledvmtentriestemplist.count:=len;
fcalledvmtentries:=tfphashlist.create;
for i:=0 to len-1 do
fcalledvmtentriestemplist[i]:=tcalledvmtentries.ppuload(ppufile);
end;
@ -167,6 +186,9 @@ implementation
getmem(fmaybecreatedbyclassrefdeftypesderefs,fmaybecreatedbyclassrefdeftypes.count*sizeof(tderef));
for i:=0 to fmaybecreatedbyclassrefdeftypes.count-1 do
fmaybecreatedbyclassrefdeftypesderefs^[i].build(fmaybecreatedbyclassrefdeftypes[i]);
for i:=0 to fcalledvmtentries.count-1 do
tcalledvmtentries(fcalledvmtentries[i]).objdefderef.build(tcalledvmtentries(fcalledvmtentries[i]).objdef);
end;
@ -178,6 +200,8 @@ implementation
procedure tunitwpoinfo.deref;
var
i: longint;
len: longint;
begin
{ don't free deref arrays immediately after use, as the types may need
re-resolving in case a unit needs to be reloaded
@ -190,6 +214,23 @@ implementation
for i:=0 to fmaybecreatedbyclassrefdeftypes.count-1 do
fmaybecreatedbyclassrefdeftypes[i]:=fmaybecreatedbyclassrefdeftypesderefs^[i].resolve;
{ in case we are re-resolving, free previous batch }
if (fcalledvmtentries.count<>0) then
{ don't just re-deref, in case the name might have changed (?) }
fcalledvmtentries.clear;
{ allocate enough internal memory in one go }
fcalledvmtentries.capacity:=fcalledvmtentriestemplist.count;
{ now resolve all items in the list and add them to the hash table }
for i:=0 to fcalledvmtentriestemplist.count-1 do
begin
with tcalledvmtentries(fcalledvmtentriestemplist[i]) do
begin
objdef:=tdef(objdefderef.resolve);
fcalledvmtentries.add(tobjectdef(objdef).vmt_mangledname,
fcalledvmtentriestemplist[i]);
end;
end;
end;

74
tests/test/opt/twpo7.pp Normal file
View File

@ -0,0 +1,74 @@
{ %wpoparas=devirtcalls,optvmts }
{ %wpopasses=1 }
{$mode objfpc}
type
tu1 = class
procedure u1proccalled; virtual;
procedure u1proccalledinoverride; virtual;
procedure u1proccallednotoverridden; virtual;
procedure u1procnotcalled; virtual;
procedure u1procaddrtaken; virtual;
end;
tu2 = class(tu1)
procedure u1proccalledinoverride; override;
end;
procedure tu1.u1proccalled;
begin
writeln('u1proccalled in u1');
end;
procedure tu1.u1proccalledinoverride;
begin
writeln('u1proccalledinoverride in u1');
if (self.classtype=tu1) then
halt(3);
end;
procedure tu1.u1proccallednotoverridden;
begin
writeln('u1proccallednotoverridden in u1');
if not(self.classtype = tu1) then
halt(4);
end;
procedure tu1.u1procnotcalled;
begin
writeln('u1procnotcalled in u1');
halt(1);
end;
procedure tu1.u1procaddrtaken;
begin
writeln('procvar called');
end;
procedure tu2.u1proccalledinoverride;
begin
writeln('u1proccalledinoverride in u2');
if (self.classtype <> tu2) then
halt(10);
end;
var
u1: tu1;
u2: tu2;
p: procedure of object;
begin
u1:=tu1.create;
u1.u1proccalled;
u1.u1proccallednotoverridden;
u1.free;
u2:=tu2.create;
p:=@u2.u1procaddrtaken;
p();
u2.u1proccalled;
u2.u1proccalledinoverride;
u2.free;
end.