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

    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 -

.gitattributes

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

compiler/cclasses.pas

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

compiler/ncgld.pas

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

compiler/ncgrtti.pas

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

compiler/optvirt.pas

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

compiler/ppu.pas

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

compiler/symdef.pas

@@ -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
 ****************************************************************************}

compiler/wpobase.pas

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

compiler/wpoinfo.pas

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

tests/test/opt/twpo7.pp

@@ -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:[email protected];
+  p();
+  u2.u1proccalled;
+  u2.u1proccalledinoverride;
+  u2.free;
+end.