Merged revisions 11878,11881-11882,11889,11891-11893,11895,11899-11902,11935,11938,12212,12304,12308-12310,12316,12330-12332,12334,12339-12340 via svnmerge from

svn+ssh://[email protected]/FPC/svn/fpc/branches/wpo

........
r11878 | jonas | 2008-10-11 02:25:18 +0200 (Sat, 11 Oct 2008) | 19 lines

  + initial implementation of whole-program optimisation framework
  + implementation of whole-program devirtualisation
  o use:
     a) generate whole-program optimisation information (no need
        to completely compile the program and all of its units
        with -OW/-FW, only the main program is sufficient)
      fpc -OWdevirtcalls -FWmyprog.wpo myprog
     b) use it to optimise the program
      fpc -B -Owdevirtcalls -Fwmyprog.wpo myprog
     (the -B is not required, but only sources recompiled during
      the second pass will actually be optimised -- if you want,
      you can even rebuild the rtl devirtualised for a particular 
      program; and these options can obviously also be used         
      together with regular optimisation switches)
  o warning:
    - there are no checks yet to ensure that you do not use 
      units optimised for a particular program with another
      program (or with a changed version of the same program)

........
r11881 | jonas | 2008-10-11 19:35:52 +0200 (Sat, 11 Oct 2008) | 13 lines

  * extracted code to detect constructed class/object types from
    tcallnode.gen_vmt_tree into its own method to avoid clutter
  * detect x.classtype.create constructs (with classtype = the
    system.tobject.classtype method), and treat them as if a
    "class of x" has been instantiated rather than a
    "class of tobject". this required storing the instantiated
    classrefs in their own array though, because at such a
    point we don't have a "class of x" tdef available (so
    now "x", and all other defs instantiated via a classref,
    are now stored as tobjectdefs in a separate array)
  + support for devirtualising class methods (including
    constructors)

........
r11882 | jonas | 2008-10-11 20:44:02 +0200 (Sat, 11 Oct 2008) | 7 lines

  + -Owoptvmts whole program optimisation which replaces vmt entries
    with method names of child classes in case the current class'
    method can never be called (e.g., because this class is never
    instantiated). As a result, such methods can then be removed
    by dead code removal/smart linking (not much effect for either
    the compiler, lazarus or a trivial lazarus app though).

........
r11889 | jonas | 2008-10-12 14:29:54 +0200 (Sun, 12 Oct 2008) | 2 lines

  * some comment fixes

........
r11891 | jonas | 2008-10-12 18:49:13 +0200 (Sun, 12 Oct 2008) | 4 lines

  * fixed twpofilereader.getnextnoncommentline() when reusing a previously
    read line
  * fixed skipping of unnecessary wpo feedback file sections

........
r11892 | jonas | 2008-10-12 23:42:43 +0200 (Sun, 12 Oct 2008) | 31 lines

  + symbol liveness wpo information extracted from smartlinked programs
    (-OW/-Owsymbolliveness)
  + use symbol liveness information to improve devirtualisation (don't
    consider classes created in code that has been dead code stripped).
    This requires at least two passes of using wpo (first uses dead code
    info to locate classes that are constructed only in dead code,
    second pass uses this info to potentially further devirtualise).
    I.e.:
     1) generate initial liveness and devirtualisation feedback
       fpc -FWtt.wpo -OWall tt.pp -Xs- -CX -XX
     2) use previously generated feedback, and regenerate new feedback
        based on this (i.e., disregard classes created in dead code)
       fpc -FWtt-1.wpo -OWall -Fwtt.wo -Owall tt.pp -Xs- -CX -XX
     3) use the newly generated feedback (in theory, it is possible
        that even more opportunities pop up afterwards; you can
        continue until the program does not get smaller anymore)
       fpc -Fwtt-1.wpo -Owall tt.pp -CX -XX
  * changed all message() to cgmessage() calls so the set codegenerror
  * changed static fsectionhandlers field to a regular field called
    fwpocomponents
  * changed registration of wpocomponents: no longer happens in the
    initialization section of their unit, but in the InitWpo routine
    (which has been moved from the woinfo to the wpo unit). This way
    you can register different classes based on the target/parameters.
  + added static method to twpocomponentbase for checking whether
    the command line parameters don't conflict with the requested
    optimisations (e.g. generating liveness info requires that
    smartlinking is turned on)
  + added static method to twpocomponentbase to request the
    section name

........
r11893 | jonas | 2008-10-12 23:53:57 +0200 (Sun, 12 Oct 2008) | 3 lines

  * fixed comment error (twpodeadcodeinfo keeps a list of live,
    not dead symbols)

........
r11895 | jonas | 2008-10-13 00:13:59 +0200 (Mon, 13 Oct 2008) | 2 lines

  + documented -OW<x>, -Ow<x>, -FW<x> and -Fw<x> wpo parameters

........
r11899 | jonas | 2008-10-14 22:14:56 +0200 (Tue, 14 Oct 2008) | 2 lines

  * replaced hardcoded string with objdumpsearchstr constant

........
r11900 | jonas | 2008-10-14 22:15:25 +0200 (Tue, 14 Oct 2008) | 2 lines

  * reset wpofeedbackinput and wpofeedbackoutput in wpodone

........
r11901 | jonas | 2008-10-14 22:16:07 +0200 (Tue, 14 Oct 2008) | 2 lines

  * various additional comments and comment fixes

........
r11902 | jonas | 2008-10-15 18:09:42 +0200 (Wed, 15 Oct 2008) | 5 lines

  * store vmt procdefs in the ppu files so we don't have to use a hack to
    regenerate them for whole-program optimisation
  * fixed crash when performing devirtualisation optimisation on programs
    that do not construct any classes/objects with optimisable vmts

........
r11935 | jonas | 2008-10-19 12:24:26 +0200 (Sun, 19 Oct 2008) | 4 lines

  * set the vmt entries of non-class virtual methods of not instantiated
    objects/classes to FPC_ABSTRACTERROR so the code they refer to can
    be thrown away if it is not referred to in any other way either

........
r11938 | jonas | 2008-10-19 20:55:02 +0200 (Sun, 19 Oct 2008) | 7 lines

  * record all classrefdefs/objdefs for which a loadvmtaddrnode is generated,
    and instead of marking all classes that derive from instantiated
    classrefdefs as instantiated, only mark those classes from the above
    collection that derive from instantiated classrefdefs as
    instantiated (since to instantiate a class, you have to load its vmt
    somehow -- this may be broken by using assembler code though)

........
r12212 | jonas | 2008-11-23 12:26:34 +0100 (Sun, 23 Nov 2008) | 3 lines

  * fixed to work with the new vmtentries that are always available and
    removed previously added code to save/load vmtentries to ppu files

........
r12304 | jonas | 2008-12-05 22:23:30 +0100 (Fri, 05 Dec 2008) | 4 lines

  * check whether the correct wpo feedback file is used in the current
    compilation when using units that were compiled using wpo information
    during a previous compilation run

........
r12308 | jonas | 2008-12-06 18:03:39 +0100 (Sat, 06 Dec 2008) | 2 lines

  * abort compilation if an error occurred during wpo initialisation

........
r12309 | jonas | 2008-12-06 18:04:28 +0100 (Sat, 06 Dec 2008) | 3 lines

  * give an error message instead of crashing with an io exception if the
    compiler is unable to create the wpo feedback file specified using -FW

........
r12310 | jonas | 2008-12-06 18:12:43 +0100 (Sat, 06 Dec 2008) | 3 lines

  * don't let the used wpo feedback file influence the interface crc (there's
    a separate check for such changes)

........
r12316 | jonas | 2008-12-08 19:08:25 +0100 (Mon, 08 Dec 2008) | 3 lines

  * document the format of the sections of the wpo feedback file inside the
    feedback file itself

........
r12330 | jonas | 2008-12-10 22:26:47 +0100 (Wed, 10 Dec 2008) | 2 lines

  * use sysutils instead of dos to avoid command line length limits

........
r12331 | jonas | 2008-12-10 22:31:11 +0100 (Wed, 10 Dec 2008) | 3 lines

  + support for testing whole program optimisation tests (multiple
    compilations using successively generated feedback files)

........
r12332 | jonas | 2008-12-10 22:31:40 +0100 (Wed, 10 Dec 2008) | 2 lines

  + whole program optimisation tests

........
r12334 | jonas | 2008-12-10 22:38:07 +0100 (Wed, 10 Dec 2008) | 2 lines

  - removed unused local variable

........
r12339 | jonas | 2008-12-11 18:06:36 +0100 (Thu, 11 Dec 2008) | 2 lines

  + comments for newly added fields to tobjectdef for devirtualisation

........
r12340 | jonas | 2008-12-11 18:10:01 +0100 (Thu, 11 Dec 2008) | 2 lines

  * increase ppu version (was no longer different from trunk due to merging)

........

git-svn-id: trunk@12341 -

.gitattributes

@@ -310,11 +310,13 @@ compiler/oglx.pas svneol=native#text/plain
 compiler/ogmap.pas svneol=native#text/plain
 compiler/optbase.pas svneol=native#text/plain
 compiler/optcse.pas svneol=native#text/plain
+compiler/optdead.pas svneol=native#text/plain
 compiler/optdfa.pas svneol=native#text/plain
 compiler/options.pas svneol=native#text/plain
 compiler/optloop.pas svneol=native#text/plain
 compiler/opttail.pas svneol=native#text/plain
 compiler/optutils.pas svneol=native#text/plain
+compiler/optvirt.pas svneol=native#text/plain
 compiler/owar.pas svneol=native#text/plain
 compiler/owbase.pas svneol=native#text/plain
 compiler/parabase.pas svneol=native#text/plain
@@ -576,6 +578,9 @@ compiler/vis/cpuinfo.pas svneol=native#text/plain
 compiler/vis/cpunode.pas svneol=native#text/plain
 compiler/vis/cpupara.pas svneol=native#text/plain
 compiler/widestr.pas svneol=native#text/plain
+compiler/wpo.pas svneol=native#text/plain
+compiler/wpobase.pas svneol=native#text/plain
+compiler/wpoinfo.pas svneol=native#text/plain
 compiler/x86/aasmcpu.pas svneol=native#text/plain
 compiler/x86/agx86att.pas svneol=native#text/plain
 compiler/x86/agx86int.pas svneol=native#text/plain
@@ -7597,6 +7602,11 @@ tests/test/opt/treg3.pp svneol=native#text/plain
 tests/test/opt/treg4.pp svneol=native#text/plain
 tests/test/opt/tretopt.pp svneol=native#text/plain
 tests/test/opt/tspace.pp svneol=native#text/plain
+tests/test/opt/twpo1.pp svneol=native#text/plain
+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/uwpo2.pp svneol=native#text/plain
 tests/test/packages/fcl-base/tgettext1.pp svneol=native#text/plain
 tests/test/packages/fcl-db/assertions.pas svneol=native#text/plain
 tests/test/packages/fcl-db/dbftoolsunit.pas svneol=native#text/plain

compiler/compiler.pas

@@ -40,7 +40,7 @@ uses
 {$ENDIF}
   verbose,comphook,systems,
   cutils,cfileutl,cclasses,globals,options,fmodule,parser,symtable,
-  assemble,link,dbgbase,import,export,tokens,pass_1
+  assemble,link,dbgbase,import,export,tokens,pass_1,wpobase,wpo
   { cpu parameter handling }
   ,cpupara
   { procinfo stuff }
@@ -145,6 +145,7 @@ begin
      DoneExport;
      DoneLinker;
      DoneAsm;
+     DoneWpo;
    end;
 { Free memory for the others }
   CompilerInited:=false;
@@ -184,6 +185,8 @@ begin
   InitExport;
   InitLinker;
   InitAsm;
+  InitWpo;
+
   CompilerInitedAfterArgs:=true;
 end;
 

compiler/fmodule.pas

@@ -44,7 +44,9 @@ interface
     uses
        cutils,cclasses,cfileutl,
        globtype,finput,ogbase,
-       symbase,symsym,aasmbase,aasmtai,aasmdata;
+       symbase,symsym,
+       wpobase,
+       aasmbase,aasmtai,aasmdata;
 
 
     const
@@ -128,6 +130,7 @@ interface
         checkforwarddefs,
         deflist,
         symlist       : TFPObjectList;
+        wpoinfo       : tunitwpoinfobase; { whole program optimization-related information that is generated during the current run for this unit }
         globalsymtable,           { pointer to the global symtable of this unit }
         localsymtable : TSymtable;{ pointer to the local symtable of this unit }
         globalmacrosymtable,           { pointer to the global macro symtable of this unit }
@@ -488,6 +491,7 @@ implementation
         derefdataintflen:=0;
         deflist:=TFPObjectList.Create(false);
         symlist:=TFPObjectList.Create(false);
+        wpoinfo:=nil;
         checkforwarddefs:=TFPObjectList.Create(false);
         globalsymtable:=nil;
         localsymtable:=nil;
@@ -598,15 +602,12 @@ implementation
         derefdata.free;
         deflist.free;
         symlist.free;
+        wpoinfo.free;
         checkforwarddefs.free;
-        if assigned(globalsymtable) then
-          globalsymtable.free;
-        if assigned(localsymtable) then
-          localsymtable.free;
-        if assigned(globalmacrosymtable) then
-          globalmacrosymtable.free;
-        if assigned(localmacrosymtable) then
-          localmacrosymtable.free;
+        globalsymtable.free;
+        localsymtable.free;
+        globalmacrosymtable.free;
+        localmacrosymtable.free;
 {$ifdef MEMDEBUG}
         memsymtable.stop;
 {$endif}
@@ -652,30 +653,20 @@ implementation
             asmdata:=nil;
           end;
         DoneDebugInfo(self);
-        if assigned(globalsymtable) then
-          begin
-            globalsymtable.free;
-            globalsymtable:=nil;
-          end;
-        if assigned(localsymtable) then
-          begin
-            localsymtable.free;
-            localsymtable:=nil;
-          end;
-        if assigned(globalmacrosymtable) then
-          begin
-            globalmacrosymtable.free;
-            globalmacrosymtable:=nil;
-          end;
-        if assigned(localmacrosymtable) then
-          begin
-            localmacrosymtable.free;
-            localmacrosymtable:=nil;
-          end;
+        globalsymtable.free;
+        globalsymtable:=nil;
+        localsymtable.free;
+        localsymtable:=nil;
+        globalmacrosymtable.free;
+        globalmacrosymtable:=nil;
+        localmacrosymtable.free;
+        localmacrosymtable:=nil;
         deflist.free;
         deflist:=TFPObjectList.Create(false);
         symlist.free;
         symlist:=TFPObjectList.Create(false);
+        wpoinfo.free;
+        wpoinfo:=nil;
         checkforwarddefs.free;
         checkforwarddefs:=TFPObjectList.Create(false);
         derefdata.free;

compiler/fpcdefs.inc

@@ -3,6 +3,7 @@
 {$H-}
 {$goto on}
 {$inline on}
+{$interfaces corba}
 
 {$ifdef win32}
   { 256 MB stack }

compiler/fppu.pas

@@ -40,6 +40,9 @@ interface
        symbase,ppu,symtype;
 
     type
+
+       { tppumodule }
+
        tppumodule = class(tmodule)
           ppufile    : tcompilerppufile; { the PPU file }
           sourcefn   : pshortstring; { Source specified with "uses .. in '..'" }
@@ -79,6 +82,7 @@ interface
           procedure readderefdata;
           procedure readImportSymbols;
           procedure readResources;
+          procedure readwpofile;
 {$IFDEF MACRO_DIFF_HINT}
           procedure writeusedmacro(p:TNamedIndexItem;arg:pointer);
           procedure writeusedmacros;
@@ -97,6 +101,7 @@ uses
   cfileutl,
   verbose,systems,version,
   symtable, symsym,
+  wpoinfo,
   scanner,
   aasmbase,ogbase,
   parser,
@@ -902,6 +907,25 @@ uses
       end;
 
 
+    procedure tppumodule.readwpofile;
+      var
+        orgwpofilename: string;
+        orgwpofiletime: longint;
+      begin
+        { check whether we are using the same wpo feedback input file as when
+          this unit was compiled (same file name and file date)
+        }
+        orgwpofilename:=ppufile.getstring;
+        orgwpofiletime:=ppufile.getlongint;
+        if (extractfilename(orgwpofilename)<>extractfilename(wpofeedbackinput)) or
+           (orgwpofiletime<>GetNamedFileTime(orgwpofilename)) then
+          { make sure we don't throw away a precompiled unit if the user simply
+            forgot to specify the right wpo feedback file
+          }
+          message3(unit_e_different_wpo_file,ppufilename^,orgwpofilename,filetimestring(orgwpofiletime));
+      end;
+
+
     procedure tppumodule.load_interface;
       var
         b : byte;
@@ -959,6 +983,8 @@ uses
                readderefdata;
              ibresources:
                readResources;
+             ibwpofile:
+               readwpofile;
              ibendinterface :
                break;
            else
@@ -1037,9 +1063,20 @@ uses
 
          { write the objectfiles and libraries that come for this unit,
            preserve the containers becuase they are still needed to load
-           the link.res. All doesn't depend on the crc! It doesn't matter
+           the link.res.
+            All doesn't depend on the crc! It doesn't matter
            if a unit is in a .o or .a file }
          ppufile.do_crc:=false;
+         { write after source files, so that we know whether or not the compiler
+           will recompile the unit when checking whether the correct wpo file is
+           used (if it will recompile the unit anyway, it doesn't matter)
+         }
+         if (wpofeedbackinput<>'') then
+           begin
+             ppufile.putstring(wpofeedbackinput);
+             ppufile.putlongint(getnamedfiletime(wpofeedbackinput));
+             ppufile.writeentry(ibwpofile);
+           end;
          writelinkcontainer(linkunitofiles,iblinkunitofiles,true);
          writelinkcontainer(linkunitstaticlibs,iblinkunitstaticlibs,true);
          writelinkcontainer(linkunitsharedlibs,iblinkunitsharedlibs,true);
@@ -1064,6 +1101,8 @@ uses
              tstoredsymtable(localsymtable).buildderef;
              tstoredsymtable(localsymtable).buildderefimpl;
            end;
+         tunitwpoinfo(wpoinfo).buildderef;
+         tunitwpoinfo(wpoinfo).buildderefimpl;
          writederefmap;
          writederefdata;
 
@@ -1098,6 +1137,9 @@ uses
          if (flags and uf_local_symtable)<>0 then
            tstoredsymtable(localsymtable).ppuwrite(ppufile);
 
+         { write whole program optimisation-related information }
+         tunitwpoinfo(wpoinfo).ppuwrite(ppufile);
+
          { the last entry ibend is written automaticly }
 
          { flush to be sure }
@@ -1301,11 +1343,16 @@ uses
             localsymtable:=tstaticsymtable.create(modulename^,moduleid);
             tstaticsymtable(localsymtable).ppuload(ppufile);
           end;
-
+          
         { we can now derefence all pointers to the implementation parts }
         tstoredsymtable(globalsymtable).derefimpl;
         if assigned(localsymtable) then
           tstoredsymtable(localsymtable).derefimpl;
+
+         { read whole program optimisation-related information }
+         wpoinfo:=tunitwpoinfo.ppuload(ppufile);
+         tunitwpoinfo(wpoinfo).deref;
+         tunitwpoinfo(wpoinfo).derefimpl;
       end;
 
 
@@ -1383,6 +1430,8 @@ uses
                       tstoredsymtable(localsymtable).deref;
                       tstoredsymtable(localsymtable).derefimpl;
                     end;
+                   tunitwpoinfo(wpoinfo).deref;
+                   tunitwpoinfo(wpoinfo).derefimpl;
                  end
                else
                  Message1(unit_u_skipping_reresolving_unit,modulename^);

compiler/globals.pas

@@ -110,6 +110,10 @@ interface
          localswitches   : tlocalswitches;
          modeswitches    : tmodeswitches;
          optimizerswitches : toptimizerswitches;
+         { generate information necessary to perform these wpo's during a subsequent compilation }
+         genwpoptimizerswitches: twpoptimizerswitches;
+         { perform these wpo's using information generated during a previous compilation }
+         dowpoptimizerswitches: twpoptimizerswitches;
          debugswitches   : tdebugswitches;
          { 0: old behaviour for sets <=256 elements
            >0: round to this size }
@@ -181,6 +185,9 @@ interface
        { specified with -FE or -FU }
        outputexedir      : TPathStr;
        outputunitdir     : TPathStr;
+       { specified with -FW and -Fw }
+       wpofeedbackinput,
+       wpofeedbackoutput : TPathStr;
 
        { things specified with parameters }
        paratarget        : tsystem;
@@ -321,6 +328,8 @@ interface
         localswitches : [cs_check_io,cs_typed_const_writable];
         modeswitches : fpcmodeswitches;
         optimizerswitches : [];
+        genwpoptimizerswitches : [];
+        dowpoptimizerswitches : [];
         debugswitches : [];
         setalloc : 0;
         packenum : 4;
@@ -417,6 +426,7 @@ interface
     function SetFpuType(const s:string;var a:tfputype):boolean;
     function UpdateAlignmentStr(s:string;var a:talignmentinfo):boolean;
     function UpdateOptimizerStr(s:string;var a:toptimizerswitches):boolean;
+    function UpdateWpoStr(s: string; var a: twpoptimizerswitches): boolean;
     function UpdateDebugStr(s:string;var a:tdebugswitches):boolean;
     function IncludeFeature(const s : string) : boolean;
     function SetMinFPConstPrec(const s: string; var a: tfloattype) : boolean;
@@ -1077,6 +1087,59 @@ implementation
       end;
 
 
+    function UpdateWpoStr(s: string; var a: twpoptimizerswitches): boolean;
+      var
+        tok   : string;
+        doset,
+        found : boolean;
+        opt   : twpoptimizerswitch;
+      begin
+        result:=true;
+        uppervar(s);
+        repeat
+          tok:=GetToken(s,',');
+          if tok='' then
+           break;
+          if Copy(tok,1,2)='NO' then
+            begin
+              delete(tok,1,2);
+              doset:=false;
+            end
+          else
+            doset:=true;
+          found:=false;
+          if (tok = 'ALL') then
+            begin
+              for opt:=low(twpoptimizerswitch) to high(twpoptimizerswitch) do
+                if doset then
+                  include(a,opt)
+                else
+                  exclude(a,opt);
+            end
+          else
+            begin
+              for opt:=low(twpoptimizerswitch) to high(twpoptimizerswitch) do
+                begin
+                  if WPOptimizerSwitchStr[opt]=tok then
+                    begin
+                      found:=true;
+                      break;
+                    end;
+                end;
+              if found then
+                begin
+                  if doset then
+                    include(a,opt)
+                  else
+                    exclude(a,opt);
+                end
+              else
+                result:=false;
+            end;
+        until false;
+      end;
+
+
     function UpdateDebugStr(s:string;var a:tdebugswitches):boolean;
       var
         tok   : string;

compiler/globtype.pas

@@ -187,12 +187,23 @@ interface
        );
        toptimizerswitches = set of toptimizerswitch;
 
+       { whole program optimizer }
+       twpoptimizerswitch = (
+         cs_wpo_devirtualize_calls,cs_wpo_optimize_vmts,
+         cs_wpo_symbol_liveness
+       );
+       twpoptimizerswitches = set of twpoptimizerswitch;
+
+
     const
        OptimizerSwitchStr : array[toptimizerswitch] of string[10] = ('',
          'LEVEL1','LEVEL2','LEVEL3',
          'REGVAR','UNCERTAIN','SIZE','STACKFRAME',
          'PEEPHOLE','ASMCSE','LOOPUNROLL','TAILREC','CSE','DFA','STRENGTH'
        );
+       WPOptimizerSwitchStr : array [twpoptimizerswitch] of string[14] = (
+         'DEVIRTCALLS','OPTVMTS','SYMBOLLIVENESS'
+       );
 
        DebugSwitchStr : array[tdebugswitch] of string[9] = ('',
          'DWARFSETS');
@@ -202,6 +213,11 @@ interface
        genericlevel2optimizerswitches = [cs_opt_level2];
        genericlevel3optimizerswitches = [cs_opt_level3];
 
+       { whole program optimizations whose information generation requires
+         information from all loaded units
+       }
+       WPOptimizationsNeedingAllUnitInfo = [cs_wpo_devirtualize_calls];
+
        featurestr : array[tfeature] of string[12] = (
          'HEAP','INITFINAL','RTTI','CLASSES','EXCEPTIONS','EXITCODE',
          'ANSISTRINGS','WIDESTRINGS','TEXTIO','CONSOLEIO','FILEIO',

compiler/msg/errore.msg

@@ -2193,7 +2193,7 @@ link_f_executable_too_big=09200_F_Executable image size is too big for $1 target
 #
 # Unit loading
 #
-# 10060 is the last used one
+# 10061 is the last used one
 #
 # BeginOfTeX
 % \section{Unit loading messages.}
@@ -2386,6 +2386,10 @@ unit_u_skipping_reresolving_unit=10059_U_Skipping re-resolving unit $1, still lo
 unit_u_unload_resunit=10060_U_Unloading resource unit $1 (not needed)
 % When you use the \var{-vu} flag, the compiler warns that it is unloading the
 % resource handling unit, since no resources are used.
+unit_e_different_wpo_file=10061_E_Unit $1 was compiled using a different whole program optimization feedback input ($2, $3); recompile it without wpo or use the same wpo feedback input file for this compilation invocation
+% When a unit has been compiled using a particular whole program optimization (wpo) feedback file (\var{-FW<x>} \var{-OW<x>}),
+% this compiled version of the unit is specialised for that particular compilation scenario and cannot be used in
+% any other context. It has to be recompiled before you can use it in another program or with another wpo feedback input file.
 % \end{description}
 # EndOfTeX
 
@@ -2506,6 +2510,83 @@ option_else_without_if=11043_F_In options file $1 at line $2 \var{\#ELSE} direct
 %\end{description}
 # EndOfTeX
 
+#
+#  Whole program optimization
+#
+# 12004 is the last used one
+#
+# BeginOfTeX
+%
+% \section{Whole program optimisation messages}
+% This section lists errors that occur when the compiler is performing
+% whole program optimization.
+wpo_cant_find_file=12000_F_Cannot open whole program optimization feedback file $1
+% The compiler cannot open the specified feedback file with whole program optimization information.
+wpo_begin_processing=12001_D_Processing whole program optimization information in wpo feedback file $1
+% The compiler starts processing whole program optimization information found in the named file.
+wpo_end_processing=12002_D_Finished processing the whole program optimization information in wpo feedback file $1
+% The compiler has finished processing the whole program optimization information found in the named file.
+wpo_expected_section=12003_E_Expected section header, but got "$2" at line $1 of wpo feedback file
+% The compiler expected a section header in the whole program optimization file (starting with \%),
+% but did not find it.
+wpo_no_section_handler=12004_W_No handler registered for whole program optimization section "$2" at line $1 of wpo feedback file, ignoring
+% The compiler has no handler to deal with the mentioned whole program optimization information
+% section, and will therefore ignore it and skip to the next section.
+wpo_found_section=12005_D_Found whole program optimization section "$1" with information about "$2"
+% The compiler encountered a section with whole program optimization information, and according
+% to its handler this section contains information usable for the mentioned purpose.
+wpo_no_input_specified=12006_F_The selected whole program optimizations require a previously generated feedback file (use -Fw to specify)
+% The compiler needs information gathered during a previous compilation run to perform the selected
+% whole program optimizations. You can specify the location of the feedback file containing this
+% information using the -Fw switch.
+wpo_not_enough_info=12007_E_No collected information necessary to perform "$1" whole program optimization found
+% While you pointed the compiler to a file containing whole program optimization feedback, it
+% did not contain the information necessary to perform the selected optimizations. You most likely
+% have to recompile the program using the appropate -OWxxx switch.
+wpo_no_output_specified=12008_F_Specify a whole program optimization feedback file to store the generated info in (using -FW)
+% You have to specify the feedback file in which the compiler has to store the whole program optimization
+% information that is generated during the compilation run. This can be done using the -FW switch.
+wpo_output_without_info_gen=12009_E_Not generating any whole program optimization information, yet a feedback file was specified (using -FW)
+% The compiler was instructed to store whole program optimization feedback into a file specified using -FW,
+% but not to actually generated any whole program optimization feedback. The classes of to be
+% generated information can be speciied using -OWxxx
+wpo_input_without_info_use=12010_E_Not performing any whole program optimizations, yet an input feedback file was specified (using -Fw)
+% The compiler was not instructed to perform any whole program optimizations (no -Owxxx parameters),
+% but nevertheless an input file with such feedback was specified (using -Fwyyy). Since this can
+% indicate that you forgot to specify an -Owxxx parameter, the compiler generates an error in this case.
+wpo_skipping_unnecessary_section=12011_D_Skipping whole program optimization section "$1", because not needed by the requested optimizations
+% The whole program optimization feedback file contains a section with information that is not
+% required by the selected whole program optimizations
+wpo_duplicate_wpotype=12012_W_Overriding previously read information for "$1" from feedback input file using information in section "$2"
+% The feedback file contains multiple sections that provide the same class of information (e.g.,
+% information about which virtual methods can be devirtualized). In this case, the information in last encountered
+% seciont is used. Turn on debugging output (-vd) to see for each section what class of information
+% it provides.
+wpo_cannot_extract_live_symbol_info_strip=12013_E_Cannot extract symbol liveness information from program when stripping symbols, use -Xs-
+% Certain symbol liveness collectors extract the symbol information from the linked program. If the symbol information
+% is stripped (option -Xs), this is not possible.
+wpo_cannot_extract_live_symbol_info_no_link=12014_E_Cannot extract symbol liveness information from program when when not linking on host
+% Certain symbol liveness collectors extract the symbol information from the linked program. If the program does not
+% get linked by the compiler, this is not possible.
+wpo_cannot_find_symbol_progs=12015_F_Cannot find "$1" or "$2" to extract symbol liveness information from linked program
+% Certain symbol liveness collectors need a helper program to extract the symbol information from the linked program.
+% This helper program is normally 'nm', which is part of the GNU binutils
+wpo_error_reading_symbol_file=12016_E_Error during reading symbol liveness information produced by "$2"
+% An error occurred during the reading of the symbol liveness file that was generated using the 'nm' or 'objdump' program. The reason
+% can be that it was shorter than expected, or that its format was not understood.
+wpo_error_executing_symbol_prog=12017_F_Error executing "$1" (exitcode: $2) to extract symbol information from linked program
+% Certain symbol liveness collectors need a helper program to extract the symbol information from the linked program.
+% The helper program produced the reported error code when it was ran on the linked program.
+wpo_symbol_live_info_needs_smart_linking=12018_E_Collection of symbol liveness information can only help when using smart linking, use -CX -XX
+% Whether or not a symbol is live is determined by looking whether it exists in the final linked program.
+% Without smart linking/dead code stripping, all symbols are always included, regardless of whether they are
+% actually used or not. So in that case all symbols will be seen as live, even if they are not.
+wpo_cant_create_feedback_file=12019_E_Cannot create specified whole program optimisation feedback file "$1"
+% The compile is unable to create the file specified using the -FW parameter to store the whole program optimisation information in.
+%\end{description}
+# EndOfTeX
+
+
 #
 # Logo (option -l)
 #
@@ -2538,6 +2619,10 @@ Supported ABI targets:
 Supported Optimizations:
   $OPTIMIZATIONS
 
+Supported Whole Program Optimizations:
+  All
+  $WPOPTIMIZATIONS
+
 This program comes under the GNU General Public Licence
 For more information read COPYING.FPC
 
@@ -2645,6 +2730,8 @@ S*2Aas_Assemble using GNU AS
 **2FR<x>_Set resource (.res) linker to <x>
 **2Fu<x>_Add <x> to unit path
 **2FU<x>_Set unit output path to <x>, overrides -FE
+**2FW<x>_Store generated whole-program optimization feedback in <x>
+**2Fw<x>_Load previously stored whole-program optimization feedback from <x>
 *g1g_Generate debug information (default format for target)
 *g2gc_Generate checks for pointers
 *g2gh_Use heaptrace unit (for memory leak/corruption debugging)
@@ -2687,6 +2774,8 @@ S*2Aas_Assemble using GNU AS
 **2Oa<x>=<y>_Set alignment
 **2Oo[NO]<x>_Enable or disable optimizations, see fpc -i for possible values
 **2Op<x>_Set target cpu for optimizing, see fpc -i for possible values
+**2OW<x>_Generate whole-program optimization feedback for optimization <x>, see fpc -i for possible values
+**2Ow<x>_Perform whole-program optimization <x>, see fpc -i for possible values
 **2Os_Optimize for size rather than speed
 **1pg_Generate profile code for gprof (defines FPC_PROFILE)
 **1R<x>_Assembler reading style:

compiler/msgidx.inc

@@ -715,6 +715,7 @@ const
   unit_u_reresolving_unit=10058;
   unit_u_skipping_reresolving_unit=10059;
   unit_u_unload_resunit=10060;
+  unit_e_different_wpo_file=10061;
   option_usage=11000;
   option_only_one_source_support=11001;
   option_def_only_for_os2=11002;
@@ -754,13 +755,33 @@ const
   option_confict_asm_debug=11041;
   option_ppc386_deprecated=11042;
   option_else_without_if=11043;
+  wpo_cant_find_file=12000;
+  wpo_begin_processing=12001;
+  wpo_end_processing=12002;
+  wpo_expected_section=12003;
+  wpo_no_section_handler=12004;
+  wpo_found_section=12005;
+  wpo_no_input_specified=12006;
+  wpo_not_enough_info=12007;
+  wpo_no_output_specified=12008;
+  wpo_output_without_info_gen=12009;
+  wpo_input_without_info_use=12010;
+  wpo_skipping_unnecessary_section=12011;
+  wpo_duplicate_wpotype=12012;
+  wpo_cannot_extract_live_symbol_info_strip=12013;
+  wpo_cannot_extract_live_symbol_info_no_link=12014;
+  wpo_cannot_find_symbol_progs=12015;
+  wpo_error_reading_symbol_file=12016;
+  wpo_error_executing_symbol_prog=12017;
+  wpo_symbol_live_info_needs_smart_linking=12018;
+  wpo_cant_create_feedback_file=12019;
   option_logo=11023;
   option_info=11024;
   option_help_pages=11025;
 
-  MsgTxtSize = 47709;
+  MsgTxtSize = 50203;
 
   MsgIdxMax : array[1..20] of longint=(
-    24,87,251,84,65,50,108,22,201,61,
-    44,1,1,1,1,1,1,1,1,1
+    24,87,251,84,65,50,108,22,201,62,
+    44,20,1,1,1,1,1,1,1,1
   );

compiler/msgtxt.inc

@@ -1,7 +1,7 @@
 {$ifdef Delphi}
-const msgtxt : array[0..000198] of string[240]=(
+const msgtxt : array[0..000209] of string[240]=(
 {$else Delphi}
-const msgtxt : array[0..000198,1..240] of char=(
+const msgtxt : array[0..000209,1..240] of char=(
 {$endif Delphi}
   '01000_T_Compiler: $1'#000+
   '01001_D_Compiler OS: $1'#000+
@@ -801,60 +801,102 @@ const msgtxt : array[0..000198,1..240] of char=(
   '10058_U_Re-resolving unit $1'#000+
   '10059_U_Skipping re-resolving unit $1, still loading used units'#000+
   '10060_U_Unloading resource unit $1 (not needed)'#000+
+  '10061_E_Unit $1 was compiled using a different whole program optimizat'+
+  'ion feedback in','put ($2, $3); recompile it without wpo or use the sam'+
+  'e wpo feedback input file for this compilation invocation'#000+
   '11000_O_$1 [options] <inputfile> [options]'#000+
   '11001_W_Only one source file supported'#000+
-  '110','02_W_DEF file can be created only for OS/2'#000+
-  '11003_E_nested response files are not supported'#000+
+  '11002_W_DEF file can be created only for OS/2'#000+
+  '1','1003_E_nested response files are not supported'#000+
   '11004_F_No source file name in command line'#000+
   '11005_N_No option inside $1 config file'#000+
   '11006_E_Illegal parameter: $1'#000+
   '11007_H_-? writes help pages'#000+
-  '11008_','F_Too many config files nested'#000+
-  '11009_F_Unable to open file $1'#000+
+  '11008_F_Too many config files nested'#000+
+  '11009_F_Unabl','e to open file $1'#000+
   '11010_D_Reading further options from $1'#000+
   '11011_W_Target is already set to: $1'#000+
   '11012_W_Shared libs not supported on DOS platform, reverting to static'+
   #000+
-  '11013_F_In options file $1 at ','line $2 too many \var{\#IF(N)DEFs} enc'+
-  'ountered'#000+
+  '11013_F_In options file $1 at line $2 too many \var{\#IF(N)DEFs} encou'+
+  'nter','ed'#000+
   '11014_F_In options file $1 at line $2 unexpected \var{\#ENDIFs} encoun'+
   'tered'#000+
   '11015_F_Open conditional at the end of the options file'#000+
-  '11016_W_Debug information generation is not supported by this',' execut'+
-  'able'#000+
-  '11017_H_Try recompiling with -dGDB'#000+
+  '11016_W_Debug information generation is not supported by this executab'+
+  'le'#000+
+  '11017_H_Try recompiling with -dG','DB'#000+
   '11018_W_You are using the obsolete switch $1'#000+
   '11019_W_You are using the obsolete switch $1, please use $2'#000+
   '11020_N_Switching assembler to default source writing assembler'#000+
-  '11021_W_Assembler output',' selected "$1" is not compatible with "$2"'#000+
-  '11022_W_"$1" assembler use forced'#000+
+  '11021_W_Assembler output selected "$1" is not compatible with "$2"'#000+
+  '1','1022_W_"$1" assembler use forced'#000+
   '11026_T_Reading options from file $1'#000+
   '11027_T_Reading options from environment $1'#000+
   '11028_D_Handling option "$1"'#000+
   '11029_O_*** press enter ***'#000+
-  '11030_H_Start of reading ','config file $1'#000+
-  '11031_H_End of reading config file $1'#000+
+  '11030_H_Start of reading config file $1'#000+
+  '11031_H_End of reading config',' file $1'#000+
   '11032_D_interpreting option "$1"'#000+
   '11036_D_interpreting firstpass option "$1"'#000+
   '11033_D_interpreting file option "$1"'#000+
   '11034_D_Reading config file "$1"'#000+
   '11035_D_found source file name "$1"'#000+
-  '1103','9_E_Unknown code page'#000+
-  '11040_F_Config file $1 is a directory'#000+
+  '11039_E_Unknown code page'#000+
+  '11040_F_Config file $1',' is a directory'#000+
   '11041_W_Assembler output selected "$1" cannot generate debug info, deb'+
   'ugging disabled'#000+
   '11042_W_Use of ppc386.cfg is deprecated, please use fpc.cfg instead'#000+
-  '11043_F_In options file $1',' at line $2 \var{\#ELSE} directive without'+
-  ' \var{\#IF(N)DEF} found'#000+
+  '11043_F_In options file $1 at line $2 \var{\#ELSE} directive without \',
+  'var{\#IF(N)DEF} found'#000+
+  '12000_F_Cannot open whole program optimization feedback file $1'#000+
+  '12001_D_Processing whole program optimization information in wpo feedb'+
+  'ack file $1'#000+
+  '12002_D_Finished processing the whole program optimization information'+
+  ' i','n wpo feedback file $1'#000+
+  '12003_E_Expected section header, but got "$2" at line $1 of wpo feedba'+
+  'ck file'#000+
+  '12004_W_No handler registered for whole program optimization section "'+
+  '$2" at line $1 of wpo feedback file, ignoring'#000+
+  '12005_D_Found whole pro','gram optimization section "$1" with informati'+
+  'on about "$2"'#000+
+  '12006_F_The selected whole program optimizations require a previously '+
+  'generated feedback file (use -Fw to specify)'#000+
+  '12007_E_No collected information necessary to perform "$1" whole p','ro'+
+  'gram optimization found'#000+
+  '12008_F_Specify a whole program optimization feedback file to store th'+
+  'e generated info in (using -FW)'#000+
+  '12009_E_Not generating any whole program optimization information, yet'+
+  ' a feedback file was specified (using -FW)',#000+
+  '12010_E_Not performing any whole program optimizations, yet an input f'+
+  'eedback file was specified (using -Fw)'#000+
+  '12011_D_Skipping whole program optimization section "$1", because not '+
+  'needed by the requested optimizations'#000+
+  '12012_W_Overriding pre','viously read information for "$1" from feedbac'+
+  'k input file using information in section "$2"'#000+
+  '12013_E_Cannot extract symbol liveness information from program when s'+
+  'tripping symbols, use -Xs-'#000+
+  '12014_E_Cannot extract symbol liveness information',' from program when'+
+  ' when not linking on host'#000+
+  '12015_F_Cannot find "$1" or "$2" to extract symbol liveness informatio'+
+  'n from linked program'#000+
+  '12016_E_Error during reading symbol liveness information produced by "'+
+  '$2"'#000+
+  '12017_F_Error executing "$1" (','exitcode: $2) to extract symbol inform'+
+  'ation from linked program'#000+
+  '12018_E_Collection of symbol liveness information can only help when u'+
+  'sing smart linking, use -CX -XX'#000+
+  '12019_E_Cannot create specified whole program optimisation feedback fi'+
+  'le "','$1"'#000+
   '11023_Free Pascal Compiler version $FPCFULLVERSION [$FPCDATE] for $FPC'+
   'CPU'#010+
   'Copyright (c) 1993-2008 by Florian Klaempfl'#000+
   '11024_Free Pascal Compiler version $FPCVERSION'#010+
   #010+
-  'Compiler',' Date      : $FPCDATE'#010+
+  'Compiler Date      : $FPCDATE'#010+
   'Compiler CPU Target: $FPCCPU'#010+
   #010+
-  'Supported targets:'#010+
+  'Supported ','targets:'#010+
   '  $OSTARGETS'#010+
   #010+
   'Supported CPU instruction sets:'#010+
@@ -866,38 +908,42 @@ const msgtxt : array[0..000198,1..240] of char=(
   'Supported ABI targets:'#010+
   '  $ABITARGETS'#010+
   #010+
-  'Supported ','Optimizations:'#010+
+  'Supported Optimizations:'#010+
   '  $OPTIMIZATIONS'#010+
   #010+
+  'Supported Whole Program Optim','izations:'#010+
+  '  All'#010+
+  '  $WPOPTIMIZATIONS'#010+
+  #010+
   'This program comes under the GNU General Public Licence'#010+
   'For more information read COPYING.FPC'#010+
   #010+
   'Report bugs,suggestions etc to:'#010+
   '                 [email protected]'#000+
-  '11025_**0*_Put + after a boolean switch opt','ion to enable it, - to di'+
+  '11025_**0*_Put + after a boolean switch ','option to enable it, - to di'+
   'sable it'#010+
   '**1a_The compiler doesn'#039't delete the generated assembler file'#010+
   '**2al_List sourcecode lines in assembler file'#010+
   '**2an_List node info in assembler file'#010+
-  '*L2ap_Use pipes instead of creating temporary assembler fil','es'#010+
+  '*L2ap_Use pipes instead of creating temporary assembler ','files'#010+
   '**2ar_List register allocation/release info in assembler file'#010+
   '**2at_List temp allocation/release info in assembler file'#010+
   '**1A<x>_Output format:'#010+
   '**2Adefault_Use default assembler'#010+
   '3*2Aas_Assemble using GNU AS'#010+
-  '3*2Anasmcoff_COFF (Go32v2) file',' using Nasm'#010+
+  '3*2Anasmcoff_COFF (Go32v2) f','ile using Nasm'#010+
   '3*2Anasmelf_ELF32 (Linux) file using Nasm'#010+
   '3*2Anasmwin32_Win32 object file using Nasm'#010+
   '3*2Anasmwdosx_Win32/WDOSX object file using Nasm'#010+
   '3*2Awasm_Obj file using Wasm (Watcom)'#010+
   '3*2Anasmobj_Obj file using Nasm'#010+
-  '3*2Amasm_Obj file using ','Masm (Microsoft)'#010+
+  '3*2Amasm_Obj file usi','ng Masm (Microsoft)'#010+
   '3*2Atasm_Obj file using Tasm (Borland)'#010+
   '3*2Aelf_ELF (Linux) using internal writer'#010+
   '3*2Acoff_COFF (Go32v2) using internal writer'#010+
   '3*2Apecoff_PE-COFF (Win32) using internal writer'#010+
   '4*2Aas_Assemble using GNU AS'#010+
-  '6*2Aas_Unix o-file ','using GNU AS'#010+
+  '6*2Aas_Unix o-fi','le using GNU AS'#010+
   '6*2Agas_GNU Motorola assembler'#010+
   '6*2Amit_MIT Syntax (old GAS)'#010+
   '6*2Amot_Standard Motorola assembler'#010+
@@ -905,24 +951,24 @@ const msgtxt : array[0..000198,1..240] of char=(
   'P*2Aas_Assemble using GNU AS'#010+
   'S*2Aas_Assemble using GNU AS'#010+
   '**1b_Generate browser info'#010+
-  '**2bl_Generate lo','cal symbol info'#010+
+  '**2bl_Generate',' local symbol info'#010+
   '**1B_Build all modules'#010+
   '**1C<x>_Code generation options:'#010+
   '**2Ca<x>_Select ABI, see fpc -i for possible values'#010+
   '**2Cb_Generate big-endian code'#010+
   '**2Cc<x>_Set default calling convention to <x>'#010+
-  '**2CD_Create also dynamic library (not',' supported)'#010+
+  '**2CD_Create also dynamic library (','not supported)'#010+
   '**2Ce_Compilation with emulated floating point opcodes'#010+
   '**2Cf<x>_Select fpu instruction set to use, see fpc -i for possible va'+
   'lues'#010+
   '**2CF<x>_Minimal floating point constant precision (default, 32, 64)'#010+
   '**2Cg_Generate PIC code'#010+
-  '**2Ch','<n>_<n> bytes heap (between 1023 and 67107840)'#010+
+  '**','2Ch<n>_<n> bytes heap (between 1023 and 67107840)'#010+
   '**2Ci_IO-checking'#010+
   '**2Cn_Omit linking stage'#010+
   '**2Co_Check overflow of integer operations'#010+
   '**2CO_Check for possible overflow of integer operations'#010+
-  '**2Cp<x>_Select instruction set, see fpc -i for pos','sible values'#010+
+  '**2Cp<x>_Select instruction set, see fpc -i for ','possible values'#010+
   '**2CP<x>=<y>_ packing settings'#010+
   '**3CPPACKSET=<y>_ <y> set allocation: 0, 1 or DEFAULT or NORMAL, 2, 4 '+
   'and 8'#010+
@@ -930,7 +976,7 @@ const msgtxt : array[0..000198,1..240] of char=(
   '**2CR_Verify object method call validity'#010+
   '**2Cs<n>_Set stack size to <n>'#010+
   '**2Ct_Stack checking'#010+
-  '**2CX_','Create also smartlinked library'#010+
+  '**2','CX_Create also smartlinked library'#010+
   '**1d<x>_Defines the symbol <x>'#010+
   '**1D_Generate a DEF file'#010+
   '**2Dd<x>_Set description to <x>'#010+
@@ -938,204 +984,212 @@ const msgtxt : array[0..000198,1..240] of char=(
   '*O2Dw_PM application'#010+
   '**1e<x>_Set path to executable'#010+
   '**1E_Same as -Cn'#010+
-  '**1fPIC_Same as -Cg',#010+
+  '**1fPIC_Same as ','-Cg'#010+
   '**1F<x>_Set file names and paths:'#010+
   '**2Fa<x>[,y]_(for a program) load units <x> and [y] before uses is par'+
   'sed'#010+
   '**2Fc<x>_Set input codepage to <x>'#010+
   '**2FC<x>_Set RC compiler binary name to <x>'#010+
-  '**2FD<x>_Set the directory where to search for compi','ler utilities'#010+
+  '**2FD<x>_Set the directory where to search for co','mpiler utilities'#010+
   '**2Fe<x>_Redirect error output to <x>'#010+
   '**2Ff<x>_Add <x> to framework path (Darwin only)'#010+
   '**2FE<x>_Set exe/unit output path to <x>'#010+
   '**2Fi<x>_Add <x> to include path'#010+
   '**2Fl<x>_Add <x> to library path'#010+
-  '**2FL<x>_Use <x> as dynamic link','er'#010+
+  '**2FL<x>_Use <x> as dynamic l','inker'#010+
   '**2Fm<x>_Load unicode conversion table from <x>.txt in the compiler di'+
   'r'#010+
   '**2Fo<x>_Add <x> to object path'#010+
   '**2Fr<x>_Load error message file <x>'#010+
   '**2FR<x>_Set resource (.res) linker to <x>'#010+
   '**2Fu<x>_Add <x> to unit path'#010+
-  '**2FU<x>_Set unit outpu','t path to <x>, overrides -FE'#010+
+  '**2FU<x>_Set unit ou','tput path to <x>, overrides -FE'#010+
+  '**2FW<x>_Store generated whole-program optimization feedback in <x>'#010+
+  '**2Fw<x>_Load previously stored whole-program optimization feedback fr'+
+  'om <x>'#010+
   '*g1g_Generate debug information (default format for target)'#010+
-  '*g2gc_Generate checks for pointers'#010+
+  '*g2','gc_Generate checks for pointers'#010+
   '*g2gh_Use heaptrace unit (for memory leak/corruption debugging)'#010+
-  '*g2gl_Use line info unit (show more info with backtr','aces)'#010+
+  '*g2gl_Use line info unit (show more info with backtraces)'#010+
   '*g2go<x>_Set debug information options'#010+
-  '*g3godwarfsets_ Enable Dwarf set debug information (breaks gdb < 6.5)'#010+
+  '*g3godwarfsets_ Enable Dwarf set debug informat','ion (breaks gdb < 6.5'+
+  ')'#010+
   '*g2gp_Preserve case in stabs symbol names'#010+
   '*g2gs_Generate stabs debug information'#010+
-  '*g2gt_Trash local variables (to detect unini','tialized uses)'#010+
+  '*g2gt_Trash local variables (to detect uninitialized uses)'#010+
   '*g2gv_Generates programs traceable with valgrind'#010+
-  '*g2gw_Generate dwarf-2 debug information (same as -gw2)'#010+
+  '*g2gw_Generate dwarf-2 debug',' information (same as -gw2)'#010+
   '*g2gw2_Generate dwarf-2 debug information'#010+
   '*g2gw3_Generate dwarf-3 debug information'#010+
   '**1i_Information'#010+
-  '**2iD_Return compil','er date'#010+
+  '**2iD_Return compiler date'#010+
   '**2iV_Return short compiler version'#010+
   '**2iW_Return full compiler version'#010+
-  '**2iSO_Return compiler OS'#010+
+  '**2iSO_Return',' compiler OS'#010+
   '**2iSP_Return compiler host processor'#010+
   '**2iTO_Return target OS'#010+
   '**2iTP_Return target processor'#010+
   '**1I<x>_Add <x> to include path'#010+
-  '**1k<x>_Pa','ss <x> to the linker'#010+
+  '**1k<x>_Pass <x> to the linker'#010+
   '**1l_Write logo'#010+
   '**1M<x>_Set language mode to <x>'#010+
-  '**2Mfpc_Free Pascal dialect (default)'#010+
+  '**2Mfpc_Free Pascal di','alect (default)'#010+
   '**2Mobjfpc_FPC mode with Object Pascal support'#010+
   '**2Mdelphi_Delphi 7 compatibility mode'#010+
   '**2Mtp_TP/BP 7.0 compatibility mode'#010+
-  '**2Mmacpas','_Macintosh Pascal dialects compatibility mode'#010+
+  '**2Mmacpas_Macintosh Pascal dialects compatibility mode'#010+
   '**1n_Do not read the default config files'#010+
-  '**1N<x>_Node tree optimizations'#010+
+  '**1N','<x>_Node tree optimizations'#010+
   '**2Nu_Unroll loops'#010+
   '**1o<x>_Change the name of the executable produced to <x>'#010+
   '**1O<x>_Optimizations:'#010+
-  '**2O-_Disable optimi','zations'#010+
+  '**2O-_Disable optimizations'#010+
   '**2O1_Level 1 optimizations (quick and debugger friendly)'#010+
-  '**2O2_Level 2 optimizations (-O1 + quick optimizations)'#010+
+  '**2O2_Level 2 optimization','s (-O1 + quick optimizations)'#010+
   '**2O3_Level 3 optimizations (-O2 + slow optimizations)'#010+
   '**2Oa<x>=<y>_Set alignment'#010+
-  '**2Oo[NO]<x>_Enable or disable optim','izations, see fpc -i for possibl'+
-  'e values'#010+
-  '**2Op<x>_Set target cpu for optimizing, see fpc -i for possible values'+
-  #010+
-  '**2Os_Optimize for size rather than speed'#010+
+  '**2Oo[NO]<x>_Enable or disable optimizations, see fpc -i for possible '+
+  'values'#010+
+  '**2Op<x>_Set target cpu for optimizing, see fpc -i ','for possible valu'+
+  'es'#010+
+  '**2OW<x>_Generate whole-program optimization feedback for optimization'+
+  ' <x>, see fpc -i for possible values'#010+
+  '**2Ow<x>_Perform whole-program optimization <x>, see fpc -i for possib'+
+  'le values'#010+
+  '**2Os_Optimize for size rather th','an speed'#010+
   '**1pg_Generate profile code for gprof (defines FPC_PROFILE)'#010+
-  '**1R<x>_Assembler reading ','style:'#010+
+  '**1R<x>_Assembler reading style:'#010+
   '**2Rdefault_Use default assembler for target'#010+
   '3*2Ratt_Read AT&T style assembler'#010+
   '3*2Rintel_Read Intel style assembler'#010+
-  '6*2RMOT_Read motorola style assembler'#010+
+  '6*2RMOT_Read motorola ','style assembler'#010+
   '**1S<x>_Syntax options:'#010+
   '**2S2_Same as -Mobjfpc'#010+
-  '**2Sc_Support operators like C (','*=,+=,/= and -=)'#010+
+  '**2Sc_Support operators like C (*=,+=,/= and -=)'#010+
   '**2Sa_Turn on assertions'#010+
   '**2Sd_Same as -Mdelphi'#010+
   '**2Se<x>_Error options. <x> is a combination of the following:'#010+
-  '**3*_<n> : Compiler halts after the <n> errors (default is 1)'#010+
+  '**3*_<n> : Compil','er halts after the <n> errors (default is 1)'#010+
   '**3*_w : Compiler also halts after warnings'#010+
-  '**3*_n',' : Compiler also halts after notes'#010+
+  '**3*_n : Compiler also halts after notes'#010+
   '**3*_h : Compiler also halts after hints'#010+
   '**2Sg_Enable LABEL and GOTO (default in -Mtp and -Mdelphi)'#010+
-  '**2Sh_Use ansistrings by default instead of shortstrings'#010+
-  '**2Si_Turn on inlining of procedures/functions d','eclared as "inline"'#010+
+  '**2Sh_Use ','ansistrings by default instead of shortstrings'#010+
+  '**2Si_Turn on inlining of procedures/functions declared as "inline"'#010+
   '**2Sk_Load fpcylix unit'#010+
   '**2SI<x>_Set interface style to <x>'#010+
   '**3SIcom_COM compatible interface (default)'#010+
-  '**3SIcorba_CORBA compatible interface'#010+
+  '**3SIcorba_CORBA comp','atible interface'#010+
   '**2Sm_Support macros like C (global)'#010+
   '**2So_Same as -Mtp'#010+
-  '**2Ss_Constructor name',' must be init (destructor must be done)'#010+
+  '**2Ss_Constructor name must be init (destructor must be done)'#010+
   '**2St_Allow static keyword in objects'#010+
   '**2Sx_Enable exception keywords (default in Delphi/ObjFPC modes)'#010+
-  '**1s_Do not call assembler and linker'#010+
+  '**','1s_Do not call assembler and linker'#010+
   '**2sh_Generate script to link on host'#010+
-  '**2st_Generate script',' to link on target'#010+
+  '**2st_Generate script to link on target'#010+
   '**2sr_Skip register allocation phase (use with -alr)'#010+
   '**1T<x>_Target operating system:'#010+
-  '3*2Temx_OS/2 via EMX (including EMX/RSX extender)'#010+
+  '3*2Temx_OS/2 via EMX (including EMX/RSX ','extender)'#010+
   '3*2Tfreebsd_FreeBSD'#010+
   '3*2Tgo32v2_Version 2 of DJ Delorie DOS extender'#010+
   '3*2Tlinux_Linux'#010+
-  '3','*2Tnetbsd_NetBSD'#010+
+  '3*2Tnetbsd_NetBSD'#010+
   '3*2Tnetware_Novell Netware Module (clib)'#010+
   '3*2Tnetwlibc_Novell Netware Module (libc)'#010+
   '3*2Topenbsd_OpenBSD'#010+
-  '3*2Tos2_OS/2 / eComStation'#010+
+  '3*2Tos2_OS/2 / eComStatio','n'#010+
   '3*2Tsunos_SunOS/Solaris'#010+
   '3*2Tsymbian_Symbian OS'#010+
   '3*2Twatcom_Watcom compatible DOS extender'#010+
-  '3*2T','wdosx_WDOSX DOS extender'#010+
+  '3*2Twdosx_WDOSX DOS extender'#010+
   '3*2Twin32_Windows 32 Bit'#010+
   '3*2Twince_Windows CE'#010+
   '4*2Tlinux_Linux'#010+
   '6*2Tamiga_Commodore Amiga'#010+
   '6*2Tatari_Atari ST/STe/TT'#010+
-  '6*2Tlinux_Linux/m68k'#010+
+  '6*2Tli','nux_Linux/m68k'#010+
   '6*2Tmacos_Macintosh m68k (not supported)'#010+
   '6*2Tpalmos_PalmOS'#010+
   'A*2Tlinux_Linux'#010+
-  'A*2Tw','ince_Windows CE'#010+
+  'A*2Twince_Windows CE'#010+
   'P*2Tamiga_AmigaOS on PowerPC'#010+
   'P*2Tdarwin_Darwin and Mac OS X on PowerPC'#010+
   'P*2Tlinux_Linux on PowerPC'#010+
-  'P*2Tmacos_Mac OS (classic) on PowerPC'#010+
+  'P*2Tmacos_Mac OS (classic) on P','owerPC'#010+
   'P*2Tmorphos_MorphOS'#010+
   'S*2Tlinux_Linux'#010+
   '**1u<x>_Undefines the symbol <x>'#010+
-  '**1U_Unit options:'#010,
+  '**1U_Unit options:'#010+
   '**2Un_Do not check where the unit name matches the file name'#010+
   '**2Ur_Generate release unit files (never automatically recompiled)'#010+
-  '**2Us_Compile a system unit'#010+
+  '**2Us_Compile a s','ystem unit'#010+
   '**1v<x>_Be verbose. <x> is a combination of the following letters:'#010+
-  '**2*_e : Show err','ors (default)       0 : Show nothing (except errors'+
-  ')'#010+
+  '**2*_e : Show errors (default)       0 : Show nothing (except errors)'#010+
   '**2*_w : Show warnings               u : Show unit info'#010+
-  '**2*_n : Show notes                  t : Show tried/used files'#010+
+  '**2*_n : Show notes                 ',' t : Show tried/used files'#010+
   '**2*_h : Show hints                  c : Show conditionals'#010+
-  '**2*_i : ','Show general info           d : Show debug info'#010+
+  '**2*_i : Show general info           d : Show debug info'#010+
   '**2*_l : Show linenumbers            r : Rhide/GCC compatibility mode'#010+
-  '**2*_a : Show everything             x : Executable info (Win32 only)'#010+
+  '**2*_a : Show everything   ','          x : Executable info (Win32 only'+
+  ')'#010+
   '**2*_b : Write file names messages with full path'#010+
-  '**','2*_v : Write fpcdebug.txt with     p : Write tree.log with parse t'+
-  'ree'#010+
+  '**2*_v : Write fpcdebug.txt with     p : Write tree.log with parse tre'+
+  'e'#010+
   '**2*_    lots of debugging info      q : Show message numbers'#010+
-  '**2*_m<x>,<y> : Don'#039't show messages numbered <x> and <y>'#010+
+  '**2*_m<x>,<y>',' : Don'#039't show messages numbered <x> and <y>'#010+
   '3*1W<x>_Target-specific options (targets)'#010+
-  'A*1W<x>_T','arget-specific options (targets)'#010+
+  'A*1W<x>_Target-specific options (targets)'#010+
   'P*1W<x>_Target-specific options (targets)'#010+
   '3*2Wb_Create a bundle instead of a library (Darwin)'#010+
-  'P*2Wb_Create a bundle instead of a library (Darwin)'#010+
+  'P*2Wb_Create a bun','dle instead of a library (Darwin)'#010+
   'p*2Wb_Create a bundle instead of a library (Darwin)'#010+
-  '3*2WB_Cre','ate a relocatable image (Windows)'#010+
+  '3*2WB_Create a relocatable image (Windows)'#010+
   'A*2WB_Create a relocatable image (Windows, Symbian)'#010+
-  '3*2WC_Specify console type application (EMX, OS/2, Windows)'#010+
+  '3*2WC_Specify console type application (EMX, OS/2, Windows)',#010+
   'A*2WC_Specify console type application (Windows)'#010+
-  'P*2WC_Specify console type application (Class','ic Mac OS)'#010+
+  'P*2WC_Specify console type application (Classic Mac OS)'#010+
   '3*2WD_Use DEFFILE to export functions of DLL or EXE (Windows)'#010+
   'A*2WD_Use DEFFILE to export functions of DLL or EXE (Windows)'#010+
-  '3*2We_Use external resources (Darwin)'#010+
+  '3*2We_Use ','external resources (Darwin)'#010+
   'P*2We_Use external resources (Darwin)'#010+
-  'p*2We_Use external resources ','(Darwin)'#010+
+  'p*2We_Use external resources (Darwin)'#010+
   '3*2WF_Specify full-screen type application (EMX, OS/2)'#010+
   '3*2WG_Specify graphic type application (EMX, OS/2, Windows)'#010+
-  'A*2WG_Specify graphic type application (Windows)'#010+
+  'A*2WG_Specify graphic',' type application (Windows)'#010+
   'P*2WG_Specify graphic type application (Classic Mac OS)'#010+
-  '3*2Wi_Use i','nternal resources (Darwin)'#010+
+  '3*2Wi_Use internal resources (Darwin)'#010+
   'P*2Wi_Use internal resources (Darwin)'#010+
   'p*2Wi_Use internal resources (Darwin)'#010+
-  '3*2WN_Do not generate relocation code, needed for debugging (Windows)'#010+
-  'A*2WN_Do not generate relocation code, needed for debugging (Window','s'+
+  '3*2WN_Do not generate relocation code, nee','ded for debugging (Windows'+
   ')'#010+
+  'A*2WN_Do not generate relocation code, needed for debugging (Windows)'#010+
   '3*2WR_Generate relocation code (Windows)'#010+
   'A*2WR_Generate relocation code (Windows)'#010+
   'P*2WT_Specify MPW tool type application (Classic Mac OS)'#010+
-  '**1X_Executable options:'#010+
+  '**1','X_Executable options:'#010+
   '**2Xc_Pass --shared/-dynamic to the linker (BeOS, Darwin, FreeBSD, Lin'+
-  'ux)',#010+
+  'ux)'#010+
   '**2Xd_Do not use standard library search path (needed for cross compil'+
   'e)'#010+
   '**2Xe_Use external linker'#010+
-  '**2Xg_Create debuginfo in a separate file and add a debuglink section '+
-  'to executable'#010+
-  '**2XD_Try to link units dynamically      (defines FPC_LI','NK_DYNAMIC)'#010+
+  '**2Xg_Create debuginfo in a separate file and',' add a debuglink sectio'+
+  'n to executable'#010+
+  '**2XD_Try to link units dynamically      (defines FPC_LINK_DYNAMIC)'#010+
   '**2Xi_Use internal linker'#010+
   '**2Xm_Generate link map'#010+
   '**2XM<x>_Set the name of the '#039'main'#039' program routine (default i'+
   's '#039'main'#039')'#010+
-  '**2XP<x>_Prepend the binutils names with the prefix <x>'#010+
-  '**2Xr<x>_Set library search path to <x> (needed fo','r cross compile) ('+
-  'BeOS, Linux)'#010+
+  '**2XP<x>_Pr','epend the binutils names with the prefix <x>'#010+
+  '**2Xr<x>_Set library search path to <x> (needed for cross compile) (Be'+
+  'OS, Linux)'#010+
   '**2XR<x>_Prepend <x> to all linker search paths (BeOS, Darwin, FreeBSD'+
   ', Linux, Mac OS, Solaris)'#010+
-  '**2Xs_Strip all symbols from executable'#010+
+  '**2Xs_Strip all sy','mbols from executable'#010+
   '**2XS_Try to link units statically (default, defines FPC_LINK_STATIC)'#010+
-  '**2','Xt_Link with static libraries (-static is passed to linker)'#010+
+  '**2Xt_Link with static libraries (-static is passed to linker)'#010+
   '**2XX_Try to smartlink units             (defines FPC_LINK_SMART)'#010+
   '**1*_'#010+
-  '**1?_Show this help'#010+
-  '**1h_Shows this help without waiting'#000
+  '**1?_Show thi','s help'#010+
+  '**1h_Shows this help without waiting'
 );

compiler/ncal.pas

@@ -72,6 +72,8 @@ interface
           procedure order_parameters;
           procedure check_inlining;
           function  pass1_normal:tnode;
+          procedure register_created_object_types;
+
 
           { inlining support }
           inlinelocals            : TFPObjectList;
@@ -206,7 +208,8 @@ implementation
       htypechk,pass_1,
       ncnv,nld,ninl,nadd,ncon,nmem,nset,
       procinfo,cpuinfo,
-      cgbase
+      cgbase,
+      wpobase
       ;
 
     type
@@ -1514,6 +1517,115 @@ implementation
       end;
 
 
+    procedure tcallnode.register_created_object_types;
+
+      function checklive(def: tdef): boolean;
+        begin
+          if assigned(current_procinfo) and
+             not(po_inline in current_procinfo.procdef.procoptions) and
+             not wpoinfomanager.symbol_live(current_procinfo.procdef.mangledname) then
+            begin
+{$ifdef debug_deadcode}
+              writeln(' NOT adding creadion of ',def.typename,' because performed in dead stripped proc: ',current_procinfo.procdef.typename);
+{$endif debug_deadcode}
+              result:=false;
+            end
+          else
+            result:=true;
+        end;
+
+      var
+        crefdef,
+        systobjectdef : tdef;
+      begin
+        { only makes sense for methods }
+        if not assigned(methodpointer) then
+          exit;
+        if (methodpointer.resultdef.typ=classrefdef) then
+          begin
+            { constructor call via classreference => allocate memory }
+            if (procdefinition.proctypeoption=potype_constructor) then
+              begin
+                { Only a typenode can be passed when it is called with <class of xx>.create }
+                if (methodpointer.nodetype=typen) then
+                  begin
+                    if checklive(methodpointer.resultdef) then
+                      { we know the exact class type being created }
+                      tclassrefdef(methodpointer.resultdef).pointeddef.register_created_object_type
+                  end
+                else
+                  begin
+                    { the loadvmtaddrnode is already created in case of classtype.create }
+                    if (methodpointer.nodetype=loadvmtaddrn) and
+                       (tloadvmtaddrnode(methodpointer).left.nodetype=typen) then
+                      begin
+                        if checklive(methodpointer.resultdef) then
+                          tclassrefdef(methodpointer.resultdef).pointeddef.register_created_object_type
+                      end
+                    else
+                      begin
+                        if checklive(methodpointer.resultdef) then
+                          begin
+                            { special case: if the classref comes from x.classtype (with classtype,
+                              being tobject.classtype) then the created instance is x or a descendant
+                              of x (rather than tobject or a descendant of tobject)
+                            }
+                            systobjectdef:=search_system_type('TOBJECT').typedef;
+                            if (methodpointer.nodetype=calln) and
+                               { not a procvar call }
+                               not assigned(right) and
+                               { procdef is owned by system.tobject }
+                               (tprocdef(tcallnode(methodpointer).procdefinition).owner.defowner=systobjectdef) and
+                               { we're calling system.tobject.classtype }
+                               (tcallnode(methodpointer).symtableprocentry.name='CLASSTYPE') and
+                               { could again be a classrefdef, but unlikely }
+                               (tcallnode(methodpointer).methodpointer.resultdef.typ=objectdef) and
+                               { don't go through this trouble if it was already a tobject }
+                               (tcallnode(methodpointer).methodpointer.resultdef<>systobjectdef) then
+                              begin
+                                { register this object type as classref, so all descendents will also
+                                  be marked as instantiatable (only the pointeddef will actually be
+                                  recorded, so it's no problem that the clasrefdef is only temporary)
+                                }
+                                crefdef:=tclassrefdef.create(tcallnode(methodpointer).methodpointer.resultdef);
+                                { and register it }
+                                crefdef.register_created_object_type;
+                              end
+                             else
+                              { the created class can be any child class as well -> register classrefdef }
+                              methodpointer.resultdef.register_created_object_type;
+                          end;
+                      end;
+                  end;
+              end
+          end
+        else
+        { Old style object }
+         if is_object(methodpointer.resultdef) then
+          begin
+            { constructor with extended syntax called from new }
+            if (cnf_new_call in callnodeflags) then
+              begin
+                if checklive(methodpointer.resultdef) then
+                  methodpointer.resultdef.register_created_object_type;
+              end
+            else
+            { normal object call like obj.proc }
+              if not(cnf_dispose_call in callnodeflags) and
+                 not(cnf_inherited in callnodeflags) and
+                 not(cnf_member_call in callnodeflags) then
+             begin
+               if (procdefinition.proctypeoption=potype_constructor) then
+                 begin
+                   if (methodpointer.nodetype<>typen) and
+                      checklive(methodpointer.resultdef) then
+                     methodpointer.resultdef.register_created_object_type;
+                 end
+             end;
+          end;
+       end;
+
+
     function tcallnode.gen_vmt_tree:tnode;
       var
         vmttree : tnode;
@@ -1654,6 +1766,7 @@ implementation
       end;
 
 
+
     function check_funcret_used_as_para(var n: tnode; arg: pointer): foreachnoderesult;
       var
         destsym : tsym absolute arg;
@@ -2686,6 +2799,12 @@ implementation
          { Check if the call can be inlined, sets the cnf_do_inline flag }
          check_inlining;
 
+         { must be called before maybe_load_in_temp(methodpointer), because
+           it converts the methodpointer into a temp in case it's a call
+           (and we want to know the original call)
+         }
+         register_created_object_types;
+
          { Maybe optimize the loading of the methodpointer using a temp. When the methodpointer
            is a calln this is even required to not execute the calln twice.
            This needs to be done after the resulttype pass, because in the resulttype we can still convert the

compiler/ncgcal.pas

@@ -86,7 +86,8 @@ implementation
 {$endif x86}
       ncgutil,
       cgobj,tgobj,
-      procinfo;
+      procinfo,
+      wpobase;
 
 
 {*****************************************************************************
@@ -863,6 +864,7 @@ implementation
 
     procedure tcgcallnode.pass_generate_code;
       var
+        name_to_call: shortstring;
         regs_to_save_int,
         regs_to_save_fpu,
         regs_to_save_mm   : Tcpuregisterset;
@@ -923,11 +925,13 @@ implementation
          { procedure variable or normal function call ? }
          if (right=nil) then
            begin
+             name_to_call:='';
              { When methodpointer is typen we don't need (and can't) load
                a pointer. We can directly call the correct procdef (PFV) }
              if (po_virtualmethod in procdefinition.procoptions) and
                 assigned(methodpointer) and
-                (methodpointer.nodetype<>typen) then
+                (methodpointer.nodetype<>typen) and
+                not wpoinfomanager.can_be_devirtualized(methodpointer.resultdef,procdefinition,name_to_call) then
                begin
                  { virtual methods require an index }
                  if tprocdef(procdefinition).extnumber=$ffff then
@@ -1018,7 +1022,10 @@ implementation
                       if (po_interrupt in procdefinition.procoptions) then
                         extra_interrupt_code;
                       extra_call_code;
-                      cg.a_call_name(current_asmdata.CurrAsmList,tprocdef(procdefinition).mangledname,po_weakexternal in procdefinition.procoptions);
+                      if (name_to_call='') then
+                        cg.a_call_name(current_asmdata.CurrAsmList,tprocdef(procdefinition).mangledname,po_weakexternal in procdefinition.procoptions)
+                      else
+                        cg.a_call_name(current_asmdata.CurrAsmList,name_to_call,po_weakexternal in procdefinition.procoptions);
                       extra_post_call_code;
                     end;
                end;

compiler/nmem.pas

@@ -30,7 +30,7 @@ interface
        symdef,symsym,symtable,symtype;
 
     type
-       tloadvmtaddrnode = class(tunarynode)
+tloadvmtaddrnode = class(tunarynode)
           constructor create(l : tnode);virtual;
           function pass_1 : tnode;override;
           function pass_typecheck:tnode;override;
@@ -170,7 +170,12 @@ implementation
          result:=nil;
          expectloc:=LOC_REGISTER;
          if left.nodetype<>typen then
-           firstpass(left);
+           firstpass(left)
+         { keep track of which classes might be instantiated via a classrefdef }
+         else if (left.resultdef.typ=classrefdef) then
+           tobjectdef(tclassrefdef(left.resultdef).pointeddef).register_maybe_created_object_type
+         else if (left.resultdef.typ=objectdef) then
+           tobjectdef(left.resultdef).register_maybe_created_object_type;
       end;
 
 

compiler/nobj.pas

@@ -112,7 +112,8 @@ implementation
        node,
        symbase,symtable,symconst,symtype,defcmp,
        dbgbase,
-       ncgrtti
+       ncgrtti,
+       wpobase
        ;
 
 
@@ -1214,7 +1215,7 @@ implementation
              internalerror(200611083);
            if (po_abstractmethod in vmtpd.procoptions) then
              procname:='FPC_ABSTRACTERROR'
-           else
+           else if not wpoinfomanager.optimized_name_for_vmt(_class,vmtpd,procname) then
              procname:=vmtpd.mangledname;
            List.concat(Tai_const.createname(procname,0));
 {$ifdef vtentry}

compiler/optdead.pas

@@ -0,0 +1,416 @@
+{
+    Copyright (c) 2008 by Jonas Maebe
+
+    Optimization information related to dead code removal
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License
+    along with this program; if not, write to the Free Software
+    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ ****************************************************************************
+}
+
+unit optdead;
+
+{$i fpcdefs.inc}
+
+  interface
+
+    uses
+      globtype,
+      cclasses,
+      symtype,
+      wpobase;
+
+    type
+
+      { twpodeadcodeinfo }
+
+      twpodeadcodeinfo = class(twpodeadcodehandler)
+       private
+        { hashtable of symbols which are live }
+        fsymbols     : tfphashlist;
+
+        procedure documentformat(writer: twposectionwriterintf);
+       public
+        constructor create; override;
+        destructor destroy; override;
+
+        class function  getwpotype: twpotype; override;
+        class function  generatesinfoforwposwitches: twpoptimizerswitches; override;
+        class function  performswpoforswitches: twpoptimizerswitches; override;
+        class function  sectionname: shortstring; override;
+
+        class procedure checkoptions; override;
+
+        { information collection }
+        procedure storewpofilesection(writer: twposectionwriterintf); override;
+
+        { information providing }
+        procedure loadfromwpofilesection(reader: twposectionreaderintf); override;
+        function  symbolinfinalbinary(const s: shortstring): boolean;override;
+
+      end;
+
+      { tdeadcodeinfofromexternallinker }
+
+      twpodeadcodeinfofromexternallinker = class(twpodeadcodeinfo)
+       private
+
+        fsymtypepos,
+        fsymnamepos  : longint;
+        fsymfile     : text;
+        fsymfilename : tcmdstr;
+        function parselinenm(const line: ansistring): boolean;
+        function parselineobjdump(const line: ansistring): boolean;
+       public
+        class procedure checkoptions; override;
+
+        { information collection }
+        procedure constructfromcompilerstate; override;
+      end;
+
+
+  implementation
+
+  uses
+    cutils,cfileutl,
+    sysutils,
+    globals,systems,fmodule,
+    verbose;
+
+
+  const
+    SYMBOL_SECTION_NAME = 'live_symbols';
+
+  { twpodeadcodeinfo }
+
+  constructor twpodeadcodeinfo.create;
+    begin
+      inherited create;
+      fsymbols:=tfphashlist.create;
+    end;
+
+
+  destructor twpodeadcodeinfo.destroy;
+    begin
+      fsymbols.free;
+      fsymbols:=nil;
+      inherited destroy;
+    end;
+
+
+  class function twpodeadcodeinfo.getwpotype: twpotype;
+    begin
+      result:=wpo_live_symbol_information;
+    end;
+
+
+  class function twpodeadcodeinfo.generatesinfoforwposwitches: twpoptimizerswitches;
+    begin
+      result:=[cs_wpo_symbol_liveness];
+    end;
+
+
+  class function twpodeadcodeinfo.performswpoforswitches: twpoptimizerswitches;
+    begin
+      result:=[cs_wpo_symbol_liveness];
+    end;
+
+
+  class function twpodeadcodeinfo.sectionname: shortstring;
+    begin
+      result:=SYMBOL_SECTION_NAME;
+    end;
+
+
+  class procedure twpodeadcodeinfo.checkoptions;
+    begin
+      { we don't have access to the symbol info if the linking
+        hasn't happend
+      }
+      if (([cs_link_on_target,cs_link_nolink] * init_settings.globalswitches) <> []) then
+        begin
+          cgmessage(wpo_cannot_extract_live_symbol_info_no_link);
+          exit;
+        end;
+
+      { without dead code stripping/smart linking, this doesn't make sense }
+      if not(cs_link_smart in init_settings.globalswitches) then
+        begin
+          cgmessage(wpo_symbol_live_info_needs_smart_linking);
+          exit;
+        end;
+    end;
+
+
+  procedure twpodeadcodeinfo.documentformat(writer: twposectionwriterintf);
+    begin
+      writer.sectionputline('# section format:');
+      writer.sectionputline('# symbol1_that_is_live');
+      writer.sectionputline('# symbol2_that_is_live');
+      writer.sectionputline('# ...');
+      writer.sectionputline('#');
+    end;
+
+
+  procedure twpodeadcodeinfo.storewpofilesection(writer: twposectionwriterintf);
+    var
+      i: longint;
+    begin
+      writer.startsection(SYMBOL_SECTION_NAME);
+      documentformat(writer);
+      for i:=0 to fsymbols.count-1 do
+        writer.sectionputline(fsymbols.nameofindex(i));
+    end;
+
+
+  procedure twpodeadcodeinfo.loadfromwpofilesection(reader: twposectionreaderintf);
+    var
+      symname: shortstring;
+    begin
+      while reader.sectiongetnextline(symname) do
+        fsymbols.add(symname,pointer(1));
+    end;
+
+
+  function twpodeadcodeinfo.symbolinfinalbinary(const s: shortstring): boolean;
+    begin
+      result:=fsymbols.find(s)<>nil;
+    end;
+
+
+  { twpodeadcodeinfofromexternallinker }
+
+{$ifdef relaxed_objdump_parsing}
+const
+  objdumpcheckstr='.text';
+{$else}
+const
+  objdumpcheckstr='F .text';
+{$endif}
+  objdumpsearchstr=' '+objdumpcheckstr;
+
+  class procedure twpodeadcodeinfofromexternallinker.checkoptions;
+    begin
+      inherited checkoptions;
+
+      { we need symbol information }
+      if (cs_link_strip in init_settings.globalswitches) then
+        begin
+          cgmessage(wpo_cannot_extract_live_symbol_info_strip);
+          exit;
+        end;
+    end;
+
+
+  function twpodeadcodeinfofromexternallinker.parselinenm(const line: ansistring): boolean;
+    begin
+      if (length(line) < fsymnamepos) then
+        begin
+          cgmessage1(wpo_error_reading_symbol_file,'nm');
+          close(fsymfile);
+          deletefile(fsymfilename);
+          result:=false;
+          exit;
+        end;
+      if (line[fsymtypepos] in ['T','t']) then
+        fsymbols.add(copy(line,fsymnamepos,length(line)),pointer(1));
+      result:=true;
+    end;
+
+
+  function twpodeadcodeinfofromexternallinker.parselineobjdump(const line: ansistring): boolean;
+    begin
+      { there are a couple of empty lines at the end }
+      if (line='') then
+        begin
+          result:=true;
+          exit;
+        end;
+      if (length(line) < fsymtypepos) then
+        begin
+          cgmessage1(wpo_error_reading_symbol_file,'objdump');
+          close(fsymfile);
+          deletefile(fsymfilename);
+          result:=false;
+          exit;
+        end;
+      if (copy(line,fsymtypepos,length(objdumpcheckstr))=objdumpcheckstr) then
+        fsymbols.add(copy(line,fsymnamepos,length(line)),pointer(1));
+      result:=true;
+    end;
+
+
+  procedure twpodeadcodeinfofromexternallinker.constructfromcompilerstate;
+
+    type
+      tparselineproc = function(const line: ansistring): boolean of object;
+
+    var
+      nmfullname,
+      objdumpfullname,
+      symbolprogfullpath  : tcmdstr;
+      line                : ansistring;
+      parseline           : tparselineproc;
+      exitcode            : longint;
+      symbolprogfound     : boolean;
+      symbolprogisnm      : boolean;
+
+
+    function findutil(const utilname: string; out fullutilname, fullutilpath: tcmdstr): boolean;
+      begin
+        result:=false;
+        fullutilname:=utilsprefix+changefileext(utilname,source_info.exeext);
+        if utilsdirectory<>'' then
+          result:=findfile(fullutilname,utilsdirectory,false,fullutilpath);
+        if not result then
+          result:=findexe(fullutilname,false,fullutilpath);
+      end;
+
+
+    function failiferror(error: boolean): boolean;
+      begin
+        result:=error;
+        if not result then
+          exit;
+        cgmessage1(wpo_error_reading_symbol_file,'fullutilname');
+{$i-}
+        close(fsymfile);
+{$i+}
+        if fileexists(fsymfilename) then
+          deletefile(fsymfilename);
+      end;
+
+
+    function setnminfo: boolean;
+      begin
+        { expected format:
+            0000bce0 T FPC_ABSTRACTERROR
+            ...
+        }
+        result:=false;
+        fsymtypepos:=pos(' ',line)+1;
+        fsymnamepos:=fsymtypepos+2;
+        if failiferror(fsymtypepos<=0) then
+          exit;
+        { make sure there's room for the name }
+        if failiferror(fsymnamepos>length(line)) then
+          exit;
+        { and that we're not in the middle of some other column }
+        if failiferror(pos(' ',copy(line,fsymnamepos,length(line)))>0) then
+          exit;
+        result:=true;
+      end;
+
+
+    function setobjdumpinfo: boolean;
+      begin
+        { expected format:
+            prog:     file format elf32-i386
+
+            SYMBOL TABLE:
+            08048080 l    d  .text  00000000 .text
+            00000000 l    d  .stabstr       00000000 .stabstr
+            00000000 l    df *ABS*  00000000 nest.pp
+            08048160 l     F .text  00000068 SYSTEM_INITSYSCALLINTF
+            ...
+        }
+        result:=false;
+        while (pos(objdumpsearchstr,line)<=0) do
+          begin
+            if failiferror(eof(fsymfile)) then
+              exit;
+            readln(fsymfile,line)
+          end;
+        fsymtypepos:=pos(objdumpsearchstr,line)+1;
+        { find begin of symbol name }
+        fsymnamepos:=(pointer(strrscan(pchar(line),' '))-pointer(@line[1]))+2;
+        { sanity check }
+        if (fsymnamepos <= fsymtypepos+length(objdumpcheckstr)) then
+          exit;
+        result:=true;
+      end;
+
+
+    begin { twpodeadcodeinfofromexternallinker }
+      { try nm }
+      symbolprogfound:=findutil('nm',nmfullname,symbolprogfullpath);
+      if not symbolprogfound then
+        begin
+          { try objdump }
+          symbolprogfound:=findutil('objdump',objdumpfullname,symbolprogfullpath);
+          symbolprogfullpath:=symbolprogfullpath+' -t ';
+          symbolprogisnm:=false;
+        end
+      else
+        begin
+          symbolprogfullpath:=symbolprogfullpath+' -p ';
+          symbolprogisnm:=true;
+        end;
+      if not symbolprogfound then
+        begin
+          cgmessage2(wpo_cannot_find_symbol_progs,nmfullname,objdumpfullname);
+          exit;
+        end;
+
+      { upper case to have the least chance of tripping some long file name
+        conversion stuff
+      }
+      fsymfilename:=outputexedir+'FPCWPO.SYM';
+      { -p gives the same kind of output with Solaris nm as
+        with GNU nm, and for GNU nm it simply means "unsorted"
+      }
+      exitcode:=shell(symbolprogfullpath+maybequoted(current_module.exefilename^)+' > '+fsymfilename);
+      if (exitcode<>0) then
+        begin
+          cgmessage2(wpo_error_executing_symbol_prog,symbolprogfullpath,tostr(exitcode));
+          if fileexists(fsymfilename) then
+            deletefile(fsymfilename);
+          exit;
+        end;
+
+      assign(fsymfile,fsymfilename);
+{$i-}
+      reset(fsymfile);
+{$i+}
+      if failiferror((ioresult<>0) or eof(fsymfile)) then
+        exit;
+      readln(fsymfile, line);
+      if (symbolprogisnm) then
+        begin
+          if not setnminfo then
+            exit;
+          parseline:=@parselinenm
+        end
+      else
+        begin
+          if not setobjdumpinfo then
+            exit;
+          parseline:=@parselineobjdump;
+        end;
+      if not parseline(line) then
+        exit;
+      while not eof(fsymfile) do
+        begin
+          readln(fsymfile,line);
+          if not parseline(line) then
+            exit;
+        end;
+      close(fsymfile);
+      deletefile(fsymfilename);
+    end;
+
+
+end.
+

compiler/options.pas

@@ -77,6 +77,7 @@ uses
   cutils,cmsgs,
   comphook,
   symtable,scanner,rabase,
+  wpobase,
   i_bsd
   ;
 
@@ -142,6 +143,7 @@ var
   cpu : tcputype;
   fpu : tfputype;
   opt : toptimizerswitch;
+  wpopt: twpoptimizerswitch;
   abi : tabi;
 begin
   p:=MessagePchar(option_info);
@@ -217,6 +219,24 @@ begin
               end;
           end;
       end
+     else if pos('$WPOPTIMIZATIONS',s)>0 then
+      begin
+        for wpopt:=low(twpoptimizerswitch) to high(twpoptimizerswitch) do
+          begin
+{           currently all whole program optimizations are platform-independent
+            if opt in supported_wpoptimizerswitches then
+}
+              begin
+                hs:=s;
+                hs1:=WPOptimizerSwitchStr[wpopt];
+                if hs1<>'' then
+                  begin
+                    Replace(hs,'$WPOPTIMIZATIONS',hs1);
+                    Comment(V_Normal,hs);
+                  end;
+              end;
+          end;
+      end
      else
       Comment(V_Normal,s);
    end;
@@ -825,6 +845,24 @@ begin
                    end;
                  'U' :
                    OutputUnitDir:=FixPath(More,true);
+                 'W',
+                 'w':
+                   begin
+                     if More<>'' then
+                       begin
+                         DefaultReplacements(More);
+                         D:=ExtractFilePath(More);
+                         if (D<>'') then
+                           D:=FixPath(D,True);
+                         D:=D+ExtractFileName(More);
+                         if (c='W') then
+                           WpoFeedbackOutput:=D
+                         else
+                           WpoFeedbackInput:=D;
+                       end
+                     else
+                       IllegalPara(opt);
+                   end;
                  else
                    IllegalPara(opt);
                end;
@@ -1043,6 +1081,18 @@ begin
                       Message2(option_obsolete_switch_use_new,'-Or','-O2 or -Ooregvar');
                     'u' :
                       Message2(option_obsolete_switch_use_new,'-Ou','-Oouncertain');
+                    'w' :
+                      begin
+                        if not UpdateWpoStr(copy(more,j+1,length(more)),init_settings.dowpoptimizerswitches) then
+                          IllegalPara(opt);
+                        break;
+                      end;
+                    'W' :
+                      begin
+                        if not UpdateWpoStr(copy(more,j+1,length(more)),init_settings.genwpoptimizerswitches) then
+                          IllegalPara(opt);
+                        break;
+                      end;
                     else
                       IllegalPara(opt);
                   end;

compiler/optvirt.pas

@@ -0,0 +1,1098 @@
+{
+    Copyright (c) 2008 by Jonas Maebe
+
+    Virtual methods optimizations (devirtualization)
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License
+    along with this program; if not, write to the Free Software
+    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ ****************************************************************************
+}
+unit optvirt;
+
+{$i fpcdefs.inc}
+
+  interface
+
+    uses
+      globtype,
+      cclasses,
+      symtype,symdef,
+      wpobase;
+
+    type
+       { node in an inheritance tree, contains a link to the parent type (if any) and to all
+        child types
+      }
+      tinheritancetreenode = class
+       private
+        fdef: tobjectdef;
+        fparent: tinheritancetreenode;
+        fchilds: tfpobjectlist;
+        finstantiated: boolean;
+
+        function getchild(index: longint): tinheritancetreenode;
+       public
+        constructor create(_parent: tinheritancetreenode; _def: tobjectdef; _instantiated: boolean);
+        { destroys both this node and all of its siblings }
+        destructor destroy; override;
+        function  childcount: longint;
+        function  haschilds: boolean;
+        property  childs[index: longint]: tinheritancetreenode read getchild;
+        property  parent: tinheritancetreenode read fparent;
+        property  def: tobjectdef read fdef;
+        property  instantiated: boolean read finstantiated write finstantiated;
+        { if def is not yet a child of this node, add it. In all cases, return node containing
+          this def (either new or existing one
+        }
+        function  maybeaddchild(_def: tobjectdef; _instantiated: boolean): tinheritancetreenode;
+      end;
+
+
+      tinheritancetreecallback = procedure(node: tinheritancetreenode; arg: pointer) of object;
+
+      tinheritancetree = class
+       private
+        { just a regular node with parent = nil }
+        froots: tinheritancetreenode;
+
+        classrefdefs: tfpobjectlist;
+
+        procedure foreachnodefromroot(root: tinheritancetreenode; proctocall: tinheritancetreecallback; arg: pointer);
+        function registerinstantiatedobjectdefrecursive(def: tobjectdef; instantiated: boolean): tinheritancetreenode;
+        procedure markvmethods(node: tinheritancetreenode; p: pointer);
+        procedure printobjectvmtinfo(node: tinheritancetreenode; arg: pointer);
+       public
+        constructor create;
+        destructor destroy; override;
+        { adds an objectdef (the def itself, and all of its parents that do not yet exist) to
+          the tree, and returns the leaf node
+        }
+        procedure registerinstantiatedobjdef(def: tdef);
+        procedure registerinstantiatedclassrefdef(def: tdef);
+        procedure checkforclassrefinheritance(def: tdef);
+        procedure foreachnode(proctocall: tinheritancetreecallback; arg: pointer);
+        procedure foreachleafnode(proctocall: tinheritancetreecallback; arg: pointer);
+        procedure optimizevirtualmethods;
+        procedure printvmtinfo;
+      end;
+
+
+      { devirtualisation information for a class }
+
+      tclassdevirtinfo = class(tfphashobject)
+       private
+        { array (indexed by vmt entry nr) of replacement statically callable method names }
+        fstaticmethodnames: tfplist;
+        { is this class instantiated by the program? }
+        finstantiated: boolean;
+        function isstaticvmtentry(vmtindex: longint; out replacementname: pshortstring): boolean;
+       public
+        constructor create(hashobjectlist:tfphashobjectlist;const n: shortstring; instantiated: boolean);
+        destructor destroy; override;
+
+        property instantiated: boolean read finstantiated;
+
+        procedure addstaticmethod(vmtindex: longint; const replacementname: shortstring);
+      end;
+
+
+      { devirtualisation information for all classes in a unit }
+
+      tunitdevirtinfo = class(tfphashobject)
+       private
+        { hashtable of classes }
+        fclasses: tfphashobjectlist;
+       public
+        constructor create(hashobjectlist:tfphashobjectlist;const n: shortstring);reintroduce;
+        destructor destroy; override;
+
+        function addclass(const n: shortstring; instantiated: boolean): tclassdevirtinfo;
+        function findclass(const n: shortstring): tclassdevirtinfo;
+      end;
+
+      { devirtualisation information for all units in a program }
+
+      { tprogdevirtinfo }
+
+      tprogdevirtinfo = class(twpodevirtualisationhandler)
+       private
+        { hashtable of tunitdevirtinfo (which contain tclassdevirtinfo) }
+        funits: tfphashobjectlist;
+
+        procedure converttreenode(node: tinheritancetreenode; arg: pointer);
+        function addunitifnew(const n: shortstring): tunitdevirtinfo;
+        function findunit(const n: shortstring): tunitdevirtinfo;
+        function getstaticname(forvmtentry: boolean; objdef, procdef: tdef; out staticname: string): boolean;
+        procedure documentformat(writer: twposectionwriterintf);
+       public
+        constructor create; override;
+        destructor destroy; override;
+
+        class function getwpotype: twpotype; override;
+        class function generatesinfoforwposwitches: twpoptimizerswitches; override;
+        class function performswpoforswitches: twpoptimizerswitches; override;
+        class function sectionname: shortstring; override;
+
+        { information collection }
+        procedure constructfromcompilerstate; override;
+        procedure storewpofilesection(writer: twposectionwriterintf); override;
+
+        { information providing }
+        procedure loadfromwpofilesection(reader: twposectionreaderintf); override;
+        function staticnameforcallingvirtualmethod(objdef, procdef: tdef; out staticname: string): boolean; override;
+        function staticnameforvmtentry(objdef, procdef: tdef; out staticname: string): boolean; override;
+
+      end;
+
+
+  implementation
+
+    uses
+      cutils,
+      fmodule,
+      symconst,
+      symbase,
+      symtable,
+      nobj,
+      verbose;
+
+    const
+      DEVIRT_SECTION_NAME = 'contextinsensitive_devirtualization';
+
+   { *************************** tinheritancetreenode ************************* }
+    
+    constructor tinheritancetreenode.create(_parent: tinheritancetreenode; _def: tobjectdef; _instantiated: boolean);
+      begin
+        fparent:=_parent;
+        fdef:=_def;
+        finstantiated:=_instantiated;
+      end;
+
+
+    destructor tinheritancetreenode.destroy;
+      begin
+        { fchilds owns its members, so it will free them too }
+        fchilds.free;
+        inherited destroy;
+      end;
+
+
+    function tinheritancetreenode.childcount: longint;
+      begin
+        if assigned(fchilds) then
+          result:=fchilds.count
+        else
+          result:=0;
+      end;
+
+
+    function tinheritancetreenode.haschilds: boolean;
+      begin
+        result:=assigned(fchilds)
+      end;
+
+
+    function tinheritancetreenode.getchild(index: longint): tinheritancetreenode;
+      begin
+        result:=tinheritancetreenode(fchilds[index]);
+      end;
+
+
+    function tinheritancetreenode.maybeaddchild(_def: tobjectdef; _instantiated: boolean): tinheritancetreenode;
+      var
+        i: longint;
+      begin
+        { sanity check }
+        if assigned(_def.childof) then 
+          begin
+            if (_def.childof<>def) then
+              internalerror(2008092201);
+          end
+        else if assigned(fparent) then
+          internalerror(2008092202);
+
+        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);
+      end;
+
+
+    { *************************** tinheritancetree ************************* }
+
+    constructor tinheritancetree.create;
+      begin
+        froots:=tinheritancetreenode.create(nil,nil,false);
+        classrefdefs:=tfpobjectlist.create(false);
+      end;
+
+
+    destructor tinheritancetree.destroy;
+      begin
+        froots.free;
+        classrefdefs.free;
+        inherited destroy;
+      end;
+      
+
+    function tinheritancetree.registerinstantiatedobjectdefrecursive(def: tobjectdef; instantiated: boolean): tinheritancetreenode;
+      begin
+        if assigned(def.childof) then
+          begin
+            { recursively add parent, of which we have no info about whether or not it is
+              instantiated at this point -> default to false (will be overridden by "true"
+              if this class is instantioted, since then registerinstantiatedobjdef() will
+              be called for this class as well)
+            }
+            result:=registerinstantiatedobjectdefrecursive(def.childof,false);
+            { and add ourselves to the parent }
+            result:=result.maybeaddchild(def,instantiated);
+          end
+        else
+          { add ourselves to the roots }
+          result:=froots.maybeaddchild(def,instantiated);
+      end;
+
+
+    procedure tinheritancetree.registerinstantiatedobjdef(def: tdef);
+      begin
+        { add the def }
+        if (def.typ=objectdef) then
+          registerinstantiatedobjectdefrecursive(tobjectdef(def),true)
+        else
+          internalerror(2008092401);
+      end;
+
+
+    procedure tinheritancetree.registerinstantiatedclassrefdef(def: tdef);
+      begin
+        { queue for later checking (these are the objectdefs
+          to which the classrefdefs point) }
+        if (def.typ=objectdef) then
+          classrefdefs.add(def)
+        else
+          internalerror(2008101401);
+      end;
+
+
+   procedure tinheritancetree.checkforclassrefinheritance(def: tdef);
+     var
+       i: longint;
+     begin
+       if (def.typ=objectdef) then
+         begin
+{$ifdef debug_devirt}
+           write('   Checking for classrefdef inheritance of ',def.typename);
+{$endif debug_devirt}
+           for i:=0 to classrefdefs.count-1 do
+             if tobjectdef(def).is_related(tobjectdef(classrefdefs[i])) then
+               begin
+{$ifdef debug_devirt}
+                 writeln('... Found: inherits from Class Of ',tobjectdef(classrefdefs[i]).typename);
+{$endif debug_devirt}
+                 registerinstantiatedobjdef(def);
+                 exit;
+               end;
+{$ifdef debug_devirt}
+           writeln('... Not found!');
+{$endif debug_devirt}
+         end;
+     end;
+
+
+    procedure tinheritancetree.foreachnodefromroot(root: tinheritancetreenode; proctocall: tinheritancetreecallback; arg: pointer);
+        
+      procedure process(const node: tinheritancetreenode);
+        var
+         i: longint;
+        begin
+          for i:=0 to node.childcount-1 do
+            if node.childs[i].haschilds then
+              begin
+                proctocall(node.childs[i],arg);
+                process(node.childs[i])
+              end
+            else
+              proctocall(node.childs[i],arg);
+        end;
+        
+      begin
+        process(root);
+      end;
+
+
+    procedure tinheritancetree.foreachnode(proctocall: tinheritancetreecallback; arg: pointer);
+      begin
+        foreachnodefromroot(froots,proctocall,arg);
+      end;
+
+
+    procedure tinheritancetree.foreachleafnode(proctocall: tinheritancetreecallback; arg: pointer);
+
+      procedure process(const node: tinheritancetreenode);
+        var
+         i: longint;
+        begin
+          for i:=0 to node.childcount-1 do
+            if node.childs[i].haschilds then
+              process(node.childs[i])
+            else
+              proctocall(node.childs[i],arg);
+        end;
+        
+      begin
+        process(froots);
+      end;
+
+
+    procedure tinheritancetree.markvmethods(node: tinheritancetreenode; p: pointer);
+      var
+        currnode: tinheritancetreenode;
+        pd: tprocdef;
+        i: longint;
+        makeallvirtual: boolean;
+      begin
+        {$IFDEF DEBUG_DEVIRT}
+        writeln('processing leaf node ',node.def.typename);
+        {$ENDIF}
+        { todo: also process interfaces (ImplementedInterfaces) }
+        if (node.def.vmtentries.count=0) then
+          exit;
+        { process all vmt entries for this class/object }
+        for i:=0 to node.def.vmtentries.count-1 do
+          begin
+            currnode:=node;
+            pd:=pvmtentry(currnode.def.vmtentries[i])^.procdef;
+            { abstract methods cannot be called directly }
+            if (po_abstractmethod in pd.procoptions) then
+              continue;
+            {$IFDEF DEBUG_DEVIRT}
+            writeln('  method ',pd.typename);
+            {$ENDIF}
+            { Now mark all virtual methods static that are the same in parent
+              classes as in this instantiated child class (only instantiated
+              classes can be leaf nodes, since only instantiated classes were
+              added to the tree).
+              If a first child does not override a parent method while a
+              a second one does, the first will mark it as statically
+              callable, but the second will set it to not statically callable.
+              In the opposite situation, the first will mark it as not
+              statically callable and the second will leave it alone.
+            }
+            makeallvirtual:=false;
+            repeat
+              if { stop when this method does not exist in a parent }
+                 (currnode.def.vmtentries.count<=i) then
+                break;
+              
+              if not assigned(currnode.def.vmcallstaticinfo) then
+                currnode.def.vmcallstaticinfo:=allocmem(currnode.def.vmtentries.count*sizeof(tvmcallstatic));
+              { same procdef as in all instantiated childs? (yes or don't know) }
+              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
+                  }
+                  if ((pvmtentry(currnode.def.vmtentries[i])^.procdef=pd) or
+                      (not currnode.instantiated and
+                       (currnode.def.vmcallstaticinfo^[i]=vmcs_default))) and
+                      not makeallvirtual then
+                    begin
+                      {$IFDEF DEBUG_DEVIRT}
+                      writeln('    marking as static for ',currnode.def.typename);
+                      {$ENDIF}
+                      currnode.def.vmcallstaticinfo^[i]:=vmcs_yes;
+                      { this is in case of a non-instantiated parent of an instantiated child:
+                        the method declared in the child will always be called here
+                      }
+                      pvmtentry(currnode.def.vmtentries[i])^.procdef:=pd;
+                    end
+                  else
+                    begin
+                      {$IFDEF DEBUG_DEVIRT}
+                      writeln('    marking as non-static for ',currnode.def.typename);
+                      {$ENDIF}
+                      { this vmt entry must also remain virtual for all parents }
+                      makeallvirtual:=true;
+                      currnode.def.vmcallstaticinfo^[i]:=vmcs_no;
+                    end;
+                  currnode:=currnode.parent;
+                end
+              else
+                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;
+            until not assigned(currnode) or
+                  not assigned(currnode.def);
+          end;
+      end;
+
+
+    procedure tinheritancetree.optimizevirtualmethods;
+      begin
+        foreachleafnode(@markvmethods,nil);
+      end;
+
+
+    procedure tinheritancetree.printobjectvmtinfo(node: tinheritancetreenode; arg: pointer);
+      var
+        i,
+        totaldevirtualised,
+        totalvirtual: ptrint;
+      begin
+        totaldevirtualised:=0;
+        totalvirtual:=0;
+        writeln(node.def.typename);
+        if (node.def.vmtentries.count=0) then
+          begin
+            writeln('  No virtual methods!');
+            exit;
+          end;
+        for i:=0 to node.def.vmtentries.count-1 do
+          if (po_virtualmethod in pvmtentry(node.def.vmtentries[i])^.procdef.procoptions) then
+            begin
+              inc(totalvirtual);
+              if (node.def.vmcallstaticinfo^[i]=vmcs_yes) then
+                begin
+                  inc(totaldevirtualised);
+                  writeln('  Devirtualised: ',pvmtentry(node.def.vmtentries[i])^.procdef.typename);
+                end;
+            end;
+        writeln('Total devirtualised: ',totaldevirtualised,'/',totalvirtual);
+        writeln;
+      end;
+
+
+    procedure tinheritancetree.printvmtinfo;
+      begin
+        foreachnode(@printobjectvmtinfo,nil);
+      end;
+
+
+    { 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)
+    }
+
+    procedure defunitclassname(objdef: tobjectdef; out unitname, classname: pshortstring);
+      const
+        mainprogname: string[2] = 'P$';
+      var
+        mainsymtab,
+        objparentsymtab : tsymtable;
+      begin
+        objparentsymtab:=objdef.symtable;
+        mainsymtab:=objparentsymtab.defowner.owner;
+        { main symtable must be static or global }
+        if not(mainsymtab.symtabletype in [staticsymtable,globalsymtable]) then
+         internalerror(200204175);
+        if (TSymtable(main_module.localsymtable)=mainsymtab) and
+            (not main_module.is_unit) then
+           { same convention as for mangled names }
+          unitname:=@mainprogname
+        else
+          unitname:=mainsymtab.name;
+        classname:=tobjectdef(objparentsymtab.defowner).objname;
+      end;
+
+
+    procedure defsdecompose(objdef: tobjectdef; procdef: tprocdef; out unitname, classname: pshortstring; out vmtentry: longint);
+      begin
+        defunitclassname(objdef,unitname,classname);
+        vmtentry:=procdef.extnumber;
+        { if it's $ffff, this is not a valid virtual method }
+        if (vmtentry=$ffff) then
+          internalerror(2008100509);
+      end;
+
+
+   { tclassdevirtinfo }
+
+    constructor tclassdevirtinfo.create(hashobjectlist:tfphashobjectlist;const n: shortstring; instantiated: boolean);
+      begin
+        inherited create(hashobjectlist,n);
+        finstantiated:=instantiated;
+        fstaticmethodnames:=tfplist.create;
+      end;
+
+    destructor tclassdevirtinfo.destroy;
+      var
+        i: longint;
+      begin
+        for i:=0 to fstaticmethodnames.count-1 do
+          if assigned(fstaticmethodnames[i]) then
+            freemem(fstaticmethodnames[i]);
+        fstaticmethodnames.free;
+        inherited destroy;
+      end;
+
+    procedure tclassdevirtinfo.addstaticmethod(vmtindex: longint;
+      const replacementname: shortstring);
+      begin
+        if (vmtindex>=fstaticmethodnames.count) then
+          fstaticmethodnames.Count:=vmtindex+10;
+        fstaticmethodnames[vmtindex]:=stringdup(replacementname);
+      end;
+
+    function tclassdevirtinfo.isstaticvmtentry(vmtindex: longint; out
+      replacementname: pshortstring): boolean;
+      begin
+         result:=false;
+         if (vmtindex>=fstaticmethodnames.count) then
+           exit;
+
+         replacementname:=fstaticmethodnames[vmtindex];
+         result:=assigned(replacementname);
+      end;
+
+    { tunitdevirtinfo }
+
+    constructor tunitdevirtinfo.create(hashobjectlist:tfphashobjectlist;const n: shortstring);
+      begin
+        inherited create(hashobjectlist,n);
+        fclasses:=tfphashobjectlist.create(true);
+      end;
+
+    destructor tunitdevirtinfo.destroy;
+      begin
+        fclasses.free;
+        inherited destroy;
+      end;
+
+    function tunitdevirtinfo.addclass(const n: shortstring; instantiated: boolean): tclassdevirtinfo;
+      begin
+        result:=findclass(n);
+        { can't have two classes with the same name in a single unit }
+        if assigned(result) then
+          internalerror(2008100501);
+        result:=tclassdevirtinfo.create(fclasses,n,instantiated);
+      end;
+
+    function tunitdevirtinfo.findclass(const n: shortstring): tclassdevirtinfo;
+      begin
+        result:=tclassdevirtinfo(fclasses.find(n));
+      end;
+
+
+    { tprogdevirtinfo }
+
+    procedure tprogdevirtinfo.converttreenode(node: tinheritancetreenode; arg: pointer);
+      var
+        i: longint;
+        unitid, classid: pshortstring;
+        unitdevirtinfo: tunitdevirtinfo;
+        classdevirtinfo: tclassdevirtinfo;
+      begin
+        if (not node.instantiated) and
+           (node.def.vmtentries.count=0) then
+          exit;
+        { always add a class entry for an instantiated class, so we can
+          fill the vmt's of non-instantiated classes with calls to
+          FPC_ABSTRACTERROR during the optimisation phase
+        }
+        defunitclassname(node.def,unitid,classid);
+        unitdevirtinfo:=addunitifnew(unitid^);
+        classdevirtinfo:=unitdevirtinfo.addclass(classid^,node.instantiated);
+        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);
+            end;
+      end;
+
+
+    constructor tprogdevirtinfo.create;
+      begin
+        inherited create;
+      end;
+
+
+    destructor tprogdevirtinfo.destroy;
+      begin
+        funits.free;
+        inherited destroy;
+      end;
+
+
+    class function tprogdevirtinfo.getwpotype: twpotype;
+      begin
+        result:=wpo_devirtualization_context_insensitive;
+      end;
+
+
+    class function tprogdevirtinfo.generatesinfoforwposwitches: twpoptimizerswitches;
+      begin
+        result:=[cs_wpo_devirtualize_calls,cs_wpo_optimize_vmts];
+      end;
+
+
+    class function tprogdevirtinfo.performswpoforswitches: twpoptimizerswitches;
+      begin
+        result:=[cs_wpo_devirtualize_calls,cs_wpo_optimize_vmts];
+      end;
+
+
+    class function tprogdevirtinfo.sectionname: shortstring;
+      begin
+        result:=DEVIRT_SECTION_NAME;
+      end;
+
+
+    procedure reset_all_impl_defs;
+
+      procedure reset_used_unit_impl_defs(hp:tmodule);
+        var
+          pu : tused_unit;
+        begin
+          pu:=tused_unit(hp.used_units.first);
+          while assigned(pu) do
+            begin
+              if not pu.u.is_reset then
+                begin
+                  { prevent infinte loop for circular dependencies }
+                  pu.u.is_reset:=true;
+                  if assigned(pu.u.localsymtable) then
+                    begin
+                      tstaticsymtable(pu.u.localsymtable).reset_all_defs;
+                      reset_used_unit_impl_defs(pu.u);
+                    end;
+                end;
+              pu:=tused_unit(pu.next);
+            end;
+        end;
+
+      var
+        hp2 : tmodule;
+      begin
+        hp2:=tmodule(loaded_units.first);
+        while assigned(hp2) do
+          begin
+            hp2.is_reset:=false;
+            hp2:=tmodule(hp2.next);
+          end;
+        reset_used_unit_impl_defs(current_module);
+      end;
+
+
+    procedure tprogdevirtinfo.constructfromcompilerstate;
+      var
+        hp: tmodule;
+        i: longint;
+        inheritancetree: tinheritancetree;
+      begin
+         { the compiler already resets all interface defs after every unit
+           compilation, but not the implementation defs (because this is only
+           done for the purpose of writing debug info, and you can never see
+           a type defined in the implementation of one unit in another unit).
+
+           Here, we want to record all classes constructed anywhere in the
+           program, also if those class(ref) types are defined in the
+           implementation of a unit. So reset the state of all defs in
+           implementation sections before starting the collection process. }
+         reset_all_impl_defs;
+         { register all instantiated class/object types }
+         hp:=tmodule(loaded_units.first);
+         while assigned(hp) do
+          begin
+            if assigned(hp.wpoinfo.createdobjtypes) then
+              for i:=0 to hp.wpoinfo.createdobjtypes.count-1 do
+                tdef(hp.wpoinfo.createdobjtypes[i]).register_created_object_type;
+            if assigned(hp.wpoinfo.createdclassrefobjtypes) then
+              for i:=0 to hp.wpoinfo.createdclassrefobjtypes.count-1 do
+                tobjectdef(hp.wpoinfo.createdclassrefobjtypes[i]).register_created_classref_type;
+            if assigned(hp.wpoinfo.maybecreatedbyclassrefdeftypes) then
+              for i:=0 to hp.wpoinfo.maybecreatedbyclassrefdeftypes.count-1 do
+                tobjectdef(hp.wpoinfo.maybecreatedbyclassrefdeftypes[i]).register_maybe_created_object_type;
+            hp:=tmodule(hp.next);
+          end;
+         inheritancetree:=tinheritancetree.create;
+
+         { add all constructed class/object types to the tree }
+{$IFDEF DEBUG_DEVIRT}
+         writeln('constructed object/class/classreftypes in ',current_module.realmodulename^);
+{$ENDIF}
+         for i := 0 to current_module.wpoinfo.createdobjtypes.count-1 do
+           begin
+             inheritancetree.registerinstantiatedobjdef(tdef(current_module.wpoinfo.createdobjtypes[i]));
+{$IFDEF DEBUG_DEVIRT}
+             write('  ',tdef(current_module.wpoinfo.createdobjtypes[i]).GetTypeName);
+{$ENDIF}
+             case tdef(current_module.wpoinfo.createdobjtypes[i]).typ of
+               objectdef:
+                 case tobjectdef(current_module.wpoinfo.createdobjtypes[i]).objecttype of
+                   odt_object:
+{$IFDEF DEBUG_DEVIRT}
+                     writeln(' (object)')
+{$ENDIF}
+                     ;
+                   odt_class:
+{$IFDEF DEBUG_DEVIRT}
+                     writeln(' (class)')
+{$ENDIF}
+                     ;
+                   else
+                     internalerror(2008092101);
+                 end;
+               else
+                 internalerror(2008092102);
+             end;
+           end;
+
+         { register all instantiated classrefdefs with the tree }
+         for i := 0 to current_module.wpoinfo.createdclassrefobjtypes.count-1 do
+           begin
+             inheritancetree.registerinstantiatedclassrefdef(tdef(current_module.wpoinfo.createdclassrefobjtypes[i]));
+{$IFDEF DEBUG_DEVIRT}
+             write('  Class Of ',tdef(current_module.wpoinfo.createdclassrefobjtypes[i]).GetTypeName);
+{$ENDIF}
+             case tdef(current_module.wpoinfo.createdclassrefobjtypes[i]).typ of
+               objectdef:
+{$IFDEF DEBUG_DEVIRT}
+                 writeln(' (classrefdef)')
+{$ENDIF}
+                 ;
+               else
+                 internalerror(2008101101);
+             end;
+           end;
+
+
+         { now add all objectdefs that are referred somewhere (via a
+           loadvmtaddr node) and that are derived from an instantiated
+           classrefdef to the tree (as they can, in theory, all
+           be instantiated as well)
+         }
+         for i := 0 to current_module.wpoinfo.maybecreatedbyclassrefdeftypes.count-1 do
+           begin
+             inheritancetree.checkforclassrefinheritance(tdef(current_module.wpoinfo.maybecreatedbyclassrefdeftypes[i]));
+{$IFDEF DEBUG_DEVIRT}
+             write('  Class Of ',tdef(current_module.wpoinfo.maybecreatedbyclassrefdeftypes[i]).GetTypeName);
+{$ENDIF}
+             case tdef(current_module.wpoinfo.maybecreatedbyclassrefdeftypes[i]).typ of
+               objectdef:
+{$IFDEF DEBUG_DEVIRT}
+                 writeln(' (classrefdef)')
+{$ENDIF}
+                 ;
+               else
+                 internalerror(2008101101);
+             end;
+           end;
+
+         inheritancetree.optimizevirtualmethods;
+{$ifdef DEBUG_DEVIRT}
+         inheritancetree.printvmtinfo;
+{$endif DEBUG_DEVIRT}
+         inheritancetree.foreachnode(@converttreenode,nil);
+         inheritancetree.free;
+      end;
+
+
+    function tprogdevirtinfo.addunitifnew(const n: shortstring): tunitdevirtinfo;
+      begin
+        if assigned(funits) then
+          result:=findunit(n)
+        else
+          begin
+            funits:=tfphashobjectlist.create;
+            result:=nil;
+          end;
+        if not assigned(result) then
+          begin
+            result:=tunitdevirtinfo.create(funits,n);
+          end;
+      end;
+
+
+    function tprogdevirtinfo.findunit(const n: shortstring): tunitdevirtinfo;
+      begin
+        result:=tunitdevirtinfo(funits.find(n));
+      end;
+
+
+    procedure tprogdevirtinfo.loadfromwpofilesection(reader: twposectionreaderintf);
+      var
+        unitid,
+        classid,
+        vmtentryname: string;
+        vmttype: string[15];
+        vmtentrynrstr: string[7];
+        classinstantiated: string[1];
+        vmtentry, error: longint;
+        unitdevirtinfo: tunitdevirtinfo;
+        classdevirtinfo: tclassdevirtinfo;
+        instantiated: boolean;
+      begin
+        { format:
+            # unitname^
+            unit1^
+            # classname&
+            class1&
+            # instantiated?
+            1
+            # vmt type (base or some interface)
+            basevmt
+            # vmt entry nr
+            0
+            # name of routine to call instead
+            staticvmtentryforslot0
+            5
+            staticvmtentryforslot5
+            intfvmt1
+            0
+            staticvmtentryforslot0
+
+            # non-instantiated class (but if we encounter a variable of this
+            # type, we can optimise class to vmtentry 1)
+            class2&
+            0
+            basevmt
+            1
+            staticvmtentryforslot1
+
+            # instantiated class without optimisable virtual methods
+            class3&
+            1
+
+            unit2^
+            1
+            class3&
+            ...
+
+            currently, only basevmt is supported (no interfaces yet)
+        }
+        { could be empty if no classes or so }
+        if not reader.sectiongetnextline(unitid) then
+          exit;
+        repeat
+          if (unitid='') or
+             (unitid[length(unitid)]<>'^') then
+            internalerror(2008100502);
+          { cut off the trailing ^ }
+          setlength(unitid,length(unitid)-1);
+          unitdevirtinfo:=addunitifnew(unitid);
+          { now read classes }
+          if not reader.sectiongetnextline(classid) then
+            internalerror(2008100505);
+          repeat
+            if (classid='') or
+               (classid[length(classid)]<>'&') then
+              internalerror(2008100503);
+            { instantiated? }
+            if not reader.sectiongetnextline(classinstantiated) then
+              internalerror(2008101901);
+            instantiated:=classinstantiated='1';
+            { cut off the trailing & }
+            setlength(classid,length(classid)-1);
+            classdevirtinfo:=unitdevirtinfo.addclass(classid,instantiated);
+            if not reader.sectiongetnextline(vmttype) then
+              internalerror(2008100506);
+            { any optimisable virtual methods? }
+            if (vmttype<>'') then
+              begin
+                { interface info is not yet supported }
+                if (vmttype<>'basevmt') then
+                  internalerror(2008100507);
+                { read all vmt entries for this class }
+                while reader.sectiongetnextline(vmtentrynrstr) and
+                      (vmtentrynrstr<>'') do
+                  begin
+                    val(vmtentrynrstr,vmtentry,error);
+                    if (error<>0) then
+                      internalerror(2008100504);
+                    if not reader.sectiongetnextline(vmtentryname) or
+                       (vmtentryname='') then
+                      internalerror(2008100508);
+                    classdevirtinfo.addstaticmethod(vmtentry,vmtentryname);
+                  end;
+              end;
+            { end of section -> exit }
+            if not(reader.sectiongetnextline(classid)) then
+              exit;
+          until (classid='') or
+                (classid[length(classid)]='^');
+          { next unit, or error }
+          unitid:=classid;
+        until false;
+      end;
+
+
+    procedure tprogdevirtinfo.documentformat(writer: twposectionwriterintf);
+      begin
+        writer.sectionputline('# section format:');
+        writer.sectionputline('# unit1^');
+        writer.sectionputline('# class1&                ; classname&');
+        writer.sectionputline('# 1                      ; instantiated or not');
+        writer.sectionputline('# basevmt                ; vmt type (base or some interface)');
+        writer.sectionputline('# # vmt entry nr');
+        writer.sectionputline('# 0                      ; vmt entry nr');
+        writer.sectionputline('# staticvmtentryforslot0 ; name or routine to call instead');
+        writer.sectionputline('# 5');
+        writer.sectionputline('# staticvmtentryforslot5');
+        writer.sectionputline('# intfvmt1');
+        writer.sectionputline('# 0');
+        writer.sectionputline('# staticvmtentryforslot0');
+        writer.sectionputline('#');
+        writer.sectionputline('# class2&');
+        writer.sectionputline('# 0                      ; non-instantiated class (can be variables of this type, e.g. TObject)');
+        writer.sectionputline('# basevmt');
+        writer.sectionputline('# 1');
+        writer.sectionputline('# staticvmtentryforslot1');
+        writer.sectionputline('#');
+        writer.sectionputline('# class3&                ; instantiated class without optimisable virtual methods');
+        writer.sectionputline('# 1');
+        writer.sectionputline('#');
+        writer.sectionputline('# unit2^');
+        writer.sectionputline('# 1');
+        writer.sectionputline('# class3&');
+        writer.sectionputline('# ...');
+        writer.sectionputline('#');
+        writer.sectionputline('# currently, only basevmt is supported (no interfaces yet)');
+        writer.sectionputline('#');
+      end;
+
+
+    procedure tprogdevirtinfo.storewpofilesection(writer: twposectionwriterintf);
+      var
+        unitcount,
+        classcount,
+        vmtentrycount: longint;
+        unitdevirtinfo: tunitdevirtinfo;
+        classdevirtinfo: tclassdevirtinfo;
+        first: boolean;
+      begin
+        { if there are no optimised virtual methods, we have stored no info }
+        if not assigned(funits) then
+          exit;
+        writer.startsection(DEVIRT_SECTION_NAME);
+        documentformat(writer);
+        for unitcount:=0 to funits.count-1 do
+          begin
+            unitdevirtinfo:=tunitdevirtinfo(funits[unitcount]);
+            writer.sectionputline(unitdevirtinfo.name+'^');
+            for classcount:=0 to unitdevirtinfo.fclasses.count-1 do
+              begin
+                classdevirtinfo:=tclassdevirtinfo(tunitdevirtinfo(funits[unitcount]).fclasses[classcount]);
+                writer.sectionputline(classdevirtinfo.name+'&');
+                writer.sectionputline(tostr(ord(classdevirtinfo.instantiated)));
+                first:=true;
+                for vmtentrycount:=0 to classdevirtinfo.fstaticmethodnames.count-1 do
+                  if assigned(classdevirtinfo.fstaticmethodnames[vmtentrycount]) then
+                    begin
+                      if first then
+                        begin
+                          writer.sectionputline('basevmt');
+                          first:=false;
+                        end;
+                      writer.sectionputline(tostr(vmtentrycount));
+                      writer.sectionputline(pshortstring(classdevirtinfo.fstaticmethodnames[vmtentrycount])^);
+                    end;
+                writer.sectionputline('');
+              end;
+          end;
+      end;
+
+
+    function tprogdevirtinfo.getstaticname(forvmtentry: boolean; objdef, procdef: tdef; out staticname: string): boolean;
+      var
+        unitid,
+        classid,
+        newname: pshortstring;
+        unitdevirtinfo: tunitdevirtinfo;
+        classdevirtinfo: tclassdevirtinfo;
+        vmtentry: longint;
+        realobjdef: tobjectdef;
+      begin
+         { class methods are in the regular vmt, so we can handle classrefs
+           the same way as plain objectdefs
+         }
+         if (objdef.typ=classrefdef) then
+           realobjdef:=tobjectdef(tclassrefdef(objdef).pointeddef)
+         else if (objdef.typ=objectdef) and
+            (tobjectdef(objdef).objecttype in [odt_class,odt_object]) then
+           realobjdef:=tobjectdef(objdef)
+         else
+           begin
+             { we don't support interfaces yet }
+             result:=false;
+             exit;
+           end;
+
+         { get the component names for the class/procdef combo }
+         defsdecompose(realobjdef,tprocdef(procdef),unitid,classid,vmtentry);
+
+         { do we have any info for this unit? }
+         unitdevirtinfo:=findunit(unitid^);
+         result:=false;
+         if not assigned(unitdevirtinfo) then
+           exit;
+         { and for this class? }
+         classdevirtinfo:=unitdevirtinfo.findclass(classid^);
+         if not assigned(classdevirtinfo) then
+           exit;
+         { if it's for a vmtentry of an objdef and the objdef is
+           not instantiated, then we can fill the vmt with pointers
+           to FPC_ABSTRACTERROR
+         }
+         if forvmtentry and
+            (objdef.typ=objectdef) and
+            not classdevirtinfo.instantiated and
+            { virtual class methods can be called even if the class is not instantiated }
+            not(po_classmethod in tprocdef(procdef).procoptions) then
+           begin
+             staticname:='FPC_ABSTRACTERROR';
+             result:=true;
+           end
+         else
+           begin
+             { now check whether it can be devirtualised, and if so to what }
+             result:=classdevirtinfo.isstaticvmtentry(vmtentry,newname);
+             if result then
+               staticname:=newname^;
+           end;
+      end;
+
+
+
+    function tprogdevirtinfo.staticnameforcallingvirtualmethod(objdef, procdef: tdef; out staticname: string): boolean;
+      begin
+        result:=getstaticname(false,objdef,procdef,staticname);
+      end;
+
+
+    function tprogdevirtinfo.staticnameforvmtentry(objdef, procdef: tdef; out staticname: string): boolean;
+      begin
+        result:=getstaticname(true,objdef,procdef,staticname);
+      end;
+
+end.

compiler/pmodules.pas

@@ -38,12 +38,14 @@ implementation
        cutils,cfileutl,cclasses,comphook,
        globals,verbose,fmodule,finput,fppu,
        symconst,symbase,symtype,symdef,symsym,symtable,
+       wpoinfo,
        aasmtai,aasmdata,aasmcpu,aasmbase,
        cgbase,cgobj,
        nbas,ncgutil,
        link,assemble,import,export,gendef,ppu,comprsrc,dbgbase,
        cresstr,procinfo,
        pexports,
+       wpobase,
        scanner,pbase,pexpr,psystem,psub,pdecsub,ptype
 {$ifdef i386}
        { fix me! }
@@ -891,6 +893,9 @@ implementation
 {$ifdef i386}
          gotvarsym : tstaticvarsym;
 {$endif i386}
+{$ifdef debug_devirt}
+         i: longint;
+{$endif debug_devirt}
       begin
          init_procinfo:=nil;
          finalize_procinfo:=nil;
@@ -1029,7 +1034,7 @@ implementation
          current_module.interface_compiled:=true;
 
          { First reload all units depending on our interface, we need to do this
-           in the implementation part to prevent errorneous circular references }
+           in the implementation part to prevent erroneous circular references }
          reload_flagged_units;
 
          { Parse the implementation section }
@@ -1040,7 +1045,7 @@ implementation
 
          parse_only:=false;
 
-         { generates static symbol table }
+         { create static symbol table }
          current_module.localsymtable:=tstaticsymtable.create(current_module.modulename^,current_module.moduleid);
 
 {$ifdef i386}
@@ -1076,6 +1081,9 @@ implementation
          symtablestack.push(current_module.globalsymtable);
          symtablestack.push(current_module.localsymtable);
 
+         { create whole program optimisation information }
+         current_module.wpoinfo:=tunitwpoinfo.create;
+
          if not current_module.interface_only then
            begin
              Message1(parser_u_parsing_implementation,current_module.modulename^);
@@ -1245,6 +1253,44 @@ implementation
             exit;
           end;
 
+{$ifdef debug_devirt}
+         { print out all instantiated class/object types }
+         writeln('constructed object/class/classreftypes in ',current_module.realmodulename^);
+         for i := 0 to current_module.wpoinfo.createdobjtypes.count-1 do
+           begin
+             write('  ',tdef(current_module.wpoinfo.createdobjtypes[i]).GetTypeName);
+             case tdef(current_module.wpoinfo.createdobjtypes[i]).typ of
+               objectdef:
+                 case tobjectdef(current_module.wpoinfo.createdobjtypes[i]).objecttype of
+                   odt_object:
+                     writeln(' (object)');
+                   odt_class:
+                     writeln(' (class)');
+                   else
+                     internalerror(2008101103);
+                 end;
+               else
+                 internalerror(2008101104);
+             end;
+           end;
+
+         for i := 0 to current_module.wpoinfo.createdclassrefobjtypes.count-1 do
+           begin
+             write('  Class Of ',tdef(current_module.wpoinfo.createdclassrefobjtypes[i]).GetTypeName);
+             case tdef(current_module.wpoinfo.createdclassrefobjtypes[i]).typ of
+               objectdef:
+                 case tobjectdef(current_module.wpoinfo.createdclassrefobjtypes[i]).objecttype of
+                   odt_class:
+                     writeln(' (classrefdef)');
+                   else
+                     internalerror(2008101105);
+                 end
+               else
+                 internalerror(2008101102);
+             end;
+           end;
+{$endif debug_devirt}
+
         Message1(unit_u_finished_compiling,current_module.modulename^);
       end;
 
@@ -1636,6 +1682,9 @@ implementation
 
          symtablestack.push(current_module.localsymtable);
 
+         { create whole program optimisation information }
+         current_module.wpoinfo:=tunitwpoinfo.create;
+
          { should we force unit initialization? }
          force_init_final:=tstaticsymtable(current_module.localsymtable).needs_init_final;
          if force_init_final then
@@ -1940,6 +1989,9 @@ implementation
 
          symtablestack.push(current_module.localsymtable);
 
+         { create whole program optimisation information }
+         current_module.wpoinfo:=tunitwpoinfo.create;
+
          { The program intialization needs an alias, so it can be called
            from the bootstrap code.}
          if islibrary then
@@ -2129,7 +2181,10 @@ implementation
          { We might need the symbols info if not using
            the default do_extractsymbolinfo
            which is a dummy function PM }
-         needsymbolinfo:=do_extractsymbolinfo<>@def_extractsymbolinfo;
+         needsymbolinfo:=
+           (do_extractsymbolinfo<>@def_extractsymbolinfo) or
+           ((current_settings.genwpoptimizerswitches*WPOptimizationsNeedingAllUnitInfo)<>[]);
+
          { release all local symtables that are not needed anymore }
          if (not needsymbolinfo) then
            free_localsymtables(current_module.localsymtable);
@@ -2176,8 +2231,12 @@ implementation
                    linker.MakeSharedLibrary
                  else
                    linker.MakeExecutable;
+
+                 { collect all necessary information for whole-program optimization }
+                 wpoinfomanager.extractwpoinfofromprogram;
                end;
 
+
              { Give Fatal with error count for linker errors }
              if (Errorcount>0) and not status.skip_error then
               begin

compiler/ppu.pas

@@ -43,7 +43,7 @@ type
 {$endif Test_Double_checksum}
 
 const
-  CurrentPPUVersion = 94;
+  CurrentPPUVersion = 95;
 
 { buffer sizes }
   maxentrysize = 1024;
@@ -126,6 +126,8 @@ const
   ibnodetree       = 80;
   ibasmsymbols     = 81;
   ibresources      = 82;
+  ibcreatedobjtypes = 83;
+  ibwpofile         = 84;
 
   ibmainname       = 90;
   { target-specific things }

compiler/symdef.pas

@@ -231,6 +231,9 @@ interface
 
        { tobjectdef }
 
+       tvmcallstatic = (vmcs_default, vmcs_yes, vmcs_no);
+       pmvcallstaticinfo = ^tmvcallstaticinfo;
+       tmvcallstaticinfo = array[0..1024*1024-1] of tvmcallstatic;
        tobjectdef = class(tabstractrecorddef)
        public
           dwarf_struct_lab : tasmsymbol;
@@ -243,11 +246,24 @@ interface
           { to be able to have a variable vmt position }
           { and no vmt field for objects without virtuals }
           vmtentries     : TFPList;
+          vmcallstaticinfo : pmvcallstaticinfo;
           vmt_offset     : longint;
-          writing_class_record_dbginfo : boolean;
           objecttype     : tobjecttyp;
           iidguid        : pguid;
           iidstr         : pshortstring;
+          writing_class_record_dbginfo,
+          { a class of this type has been created in this module }
+          created_in_current_module,
+          { a loadvmtnode for this class has been created in this
+            module, so if a classrefdef variable of this or a parent
+            class is used somewhere to instantiate a class, then this
+            class may be instantiated
+          }
+          maybe_created_in_current_module,
+          { a "class of" this particular class has been created in
+            this module
+          }
+          classref_created_in_current_module : boolean;
           { store implemented interfaces defs and name mappings }
           ImplementedInterfaces : TFPObjectList;
           constructor create(ot : tobjecttyp;const n : string;c : tobjectdef);
@@ -279,14 +295,20 @@ interface
           procedure set_parent(c : tobjectdef);
           function FindDestructor : tprocdef;
           function implements_any_interfaces: boolean;
+          procedure reset; override;
+          procedure register_created_object_type;override;
+          procedure register_maybe_created_object_type;
+          procedure register_created_classref_type;
        end;
 
        tclassrefdef = class(tabstractpointerdef)
           constructor create(def:tdef);
           constructor ppuload(ppufile:tcompilerppufile);
           procedure ppuwrite(ppufile:tcompilerppufile);override;
-          function GetTypeName:string;override;
+          function  GetTypeName:string;override;
           function  is_publishable : boolean;override;
+          procedure register_created_object_type;override;
+          procedure reset;override;
        end;
 
        tarraydef = class(tstoreddef)
@@ -2040,8 +2062,20 @@ implementation
       begin
          result:=true;
       end;
+      
+
+    procedure tclassrefdef.reset;
+      begin
+        tobjectdef(pointeddef).classref_created_in_current_module:=false;
+        inherited reset;
+      end;
 
 
+    procedure tclassrefdef.register_created_object_type;
+      begin
+        tobjectdef(pointeddef).register_created_classref_type;
+      end;
+
 {***************************************************************************
                                    TSETDEF
 ***************************************************************************}
@@ -3749,6 +3783,11 @@ implementation
              vmtentries.free;
              vmtentries:=nil;
            end;
+         if assigned(vmcallstaticinfo) then
+           begin
+             freemem(vmcallstaticinfo);
+             vmcallstaticinfo:=nil;
+           end;
          inherited destroy;
       end;
 
@@ -4196,6 +4235,49 @@ implementation
       end;
 
 
+    procedure tobjectdef.reset;
+      begin
+        inherited reset;
+        created_in_current_module:=false;
+        maybe_created_in_current_module:=false;
+        classref_created_in_current_module:=false;
+      end;
+
+
+    procedure tobjectdef.register_created_classref_type;
+      begin
+        if not classref_created_in_current_module then
+          begin
+            classref_created_in_current_module:=true;
+            current_module.wpoinfo.addcreatedobjtypeforclassref(self);
+          end;
+      end;
+
+
+    procedure tobjectdef.register_created_object_type;
+      begin
+        if not created_in_current_module then
+          begin
+            created_in_current_module:=true;
+            current_module.wpoinfo.addcreatedobjtype(self);
+          end;
+      end;
+
+
+    procedure tobjectdef.register_maybe_created_object_type;
+      begin
+        { if we know it has been created for sure, no need
+          to also record that it maybe can be created in
+          this module
+        }
+        if not (created_in_current_module) and
+           not (maybe_created_in_current_module) then
+          begin
+            maybe_created_in_current_module:=true;
+            current_module.wpoinfo.addmaybecreatedbyclassref(self);
+          end;
+      end;
+
 {****************************************************************************
                              TImplementedInterface
 ****************************************************************************}

compiler/symtype.pas

@@ -82,6 +82,7 @@ interface
          function  needs_inittable:boolean;virtual;abstract;
          function  is_related(def:tdef):boolean;virtual;
          procedure ChangeOwner(st:TSymtable);
+         procedure register_created_object_type;virtual;
       end;
 
 {************************************************
@@ -314,6 +315,10 @@ implementation
       end;
 
 
+    procedure tdef.register_created_object_type;
+      begin
+      end;
+
 {****************************************************************************
                           TSYM (base for all symtypes)
 ****************************************************************************}

compiler/wpo.pas

@@ -0,0 +1,79 @@
+{
+    Copyright (c) 2008 by Jonas Maebe
+
+    Collects all whole program optimization plugin untits
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License
+    along with this program; if not, write to the Free Software
+    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ ****************************************************************************
+}
+
+unit wpo;
+
+{$i fpcdefs.inc}
+
+interface
+
+uses
+  { all units with whole program optimisation components }
+  optvirt,optdead;
+
+
+  procedure InitWpo;
+  procedure DoneWpo;
+
+implementation
+
+  uses
+    globals,
+    comphook,
+    wpobase, wpoinfo;
+
+  { called after command line parameters have been parsed }
+  procedure InitWpo;
+    begin
+      { always create so we don't have to litter the source with if-tests }
+      wpoinfomanager:=twpoinfomanager.create;
+
+      { register the classes we can/should potentially use }
+      wpoinfomanager.registerwpocomponentclass(tprogdevirtinfo);
+      wpoinfomanager.registerwpocomponentclass(twpodeadcodeinfofromexternallinker);
+
+      { assign input/output feedback files }
+      if (wpofeedbackinput<>'') then
+        wpoinfomanager.setwpoinputfile(wpofeedbackinput);
+      if (wpofeedbackoutput<>'') then
+        wpoinfomanager.setwpooutputfile(wpofeedbackoutput);
+
+      { parse input }
+      wpoinfomanager.parseandcheckwpoinfo;
+
+      { abort if error }
+      if (codegenerror) then
+        raise ECompilerAbort.Create;
+    end;
+
+
+  procedure DoneWpo;
+    begin
+      wpoinfomanager.free;
+      wpoinfomanager:=nil;
+      wpofeedbackinput:='';
+      wpofeedbackoutput:='';
+    end;
+
+
+end.
+

compiler/wpobase.pas

@@ -0,0 +1,680 @@
+{
+    Copyright (c) 2008 by Jonas Maebe
+
+    Whole program optimisation information collection base class
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License
+    along with this program; if not, write to the Free Software
+    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+ ****************************************************************************
+}
+
+unit wpobase;
+
+{$i fpcdefs.inc}
+
+interface
+
+uses
+  globtype,
+  cclasses,
+  symtype;
+
+type
+  { the types of available whole program optimization }
+  twpotype = (wpo_devirtualization_context_insensitive,wpo_live_symbol_information);
+const
+  wpo2str: array[twpotype] of string[16] = ('devirtualization','symbol liveness');
+
+type
+  { ************************************************************************* }
+  { ******************** General base classes/interfaces ******************** }
+  { ************************************************************************* }
+
+  { interface to reading a section from a file with wpo info }
+  twposectionreaderintf = interface
+    ['{51BE3F89-C9C5-4965-9C83-AE7490C92E3E}']
+    function sectiongetnextline(out s: string): boolean;
+  end;
+
+
+  { interface to writing sections to a file with wpoinfo }
+  twposectionwriterintf = interface
+    ['{C056F0DD-62B1-4612-86C7-2D39944C4437}']
+    procedure startsection(const name: string);
+    procedure sectionputline(const s: string);
+  end;
+
+
+  { base class for wpo information stores }
+
+  { twpocomponentbase }
+
+  twpocomponentbase = class
+   public
+    constructor create; reintroduce; virtual;
+
+    { type of whole program optimization information collected/provided by
+      this class
+    }
+    class function getwpotype: twpotype; virtual; abstract;
+
+    { whole program optimizations for which this class generates information }
+    class function generatesinfoforwposwitches: twpoptimizerswitches; virtual; abstract;
+
+    { whole program optimizations performed by this class }
+    class function performswpoforswitches: twpoptimizerswitches; virtual; abstract;
+
+    { returns the name of the section parsed by this class }
+    class function sectionname: shortstring; virtual; abstract;
+
+    { checks whether the compiler options are compatible with this
+      optimization (default: don't check anything)
+    }
+    class procedure checkoptions; virtual;
+
+    { loads the information pertinent to this whole program optimization from
+      the current section being processed by reader
+    }
+    procedure loadfromwpofilesection(reader: twposectionreaderintf); virtual; abstract;
+
+    { stores the information of this component to a file in a format that can
+      be loaded again using loadfromwpofilesection()
+    }
+    procedure storewpofilesection(writer: twposectionwriterintf); virtual; abstract;
+
+    { extracts the information pertinent to this whole program optimization
+      from the current compiler state (loaded units, ...)
+    }
+    procedure constructfromcompilerstate; virtual; abstract;
+  end;
+
+  twpocomponentbaseclass = class of twpocomponentbase;
+
+
+  { forward declaration of overall wpo info manager class }
+
+  twpoinfomanagerbase = class;
+
+  { ************************************************************************* }
+  { ** Information created per unit for use during subsequent compilation *** }
+  { ************************************************************************* }
+
+  { base class of information collected per unit. Still needs to be
+    generalised for different kinds of wpo information, currently specific
+    to devirtualization.
+  }
+
+  tunitwpoinfobase = class
+   protected
+    { created object types }
+    fcreatedobjtypes: tfpobjectlist;
+    { objectdefs pointed to by created classrefdefs }
+    fcreatedclassrefobjtypes: tfpobjectlist;
+    { objtypes potentially instantiated by fcreatedclassrefobjtypes
+      (objdectdefs pointed to by classrefdefs that are
+       passed as a regular parameter, loaded in a variable, ...
+       so they can end up in a classrefdef var and be instantiated)
+    }
+    fmaybecreatedbyclassrefdeftypes: tfpobjectlist;
+   public
+    constructor create; reintroduce; virtual;
+    destructor destroy; override;
+
+    property createdobjtypes: tfpobjectlist read fcreatedobjtypes;
+    property createdclassrefobjtypes: tfpobjectlist read fcreatedclassrefobjtypes;
+    property maybecreatedbyclassrefdeftypes: tfpobjectlist read fmaybecreatedbyclassrefdeftypes;
+
+    procedure addcreatedobjtype(def: tdef);
+    procedure addcreatedobjtypeforclassref(def: tdef);
+    procedure addmaybecreatedbyclassref(def: tdef);
+  end;
+
+  { ************************************************************************* }
+  { **** Total information created for use during subsequent compilation **** }
+  { ************************************************************************* }
+
+  { class to create a file with wpo information }
+
+  { tavailablewpofilewriter }
+
+  twpofilewriter = class(tobject,twposectionwriterintf)
+   private
+    { array of class *instances* that wish to be written out to the
+      whole program optimization feedback file
+    }
+    fsectioncontents: tfpobjectlist;
+
+    ffilename: tcmdstr;
+    foutputfile: text;
+
+   public
+    constructor create(const fn: tcmdstr);
+    destructor destroy; override;
+
+    procedure writefile;
+
+    { starts a new section with name "name" }
+    procedure startsection(const name: string);
+    { writes s to the wpo file }
+    procedure sectionputline(const s: string);
+
+    { register a component instance that needs to be written
+      to the wpo feedback file
+    }
+    procedure registerwpocomponent(component: twpocomponentbase);
+  end;
+
+  { ************************************************************************* }
+  { ************ Information for use during current compilation ************* }
+  { ************************************************************************* }
+
+  { class to read a file with wpo information }
+  twpofilereader = class(tobject,twposectionreaderintf)
+   private
+    ffilename: tcmdstr;
+    flinenr: longint;
+    finputfile: text;
+    fcurline: string;
+    fusecurline: boolean;
+
+    { destination for the read information }
+    fdest: twpoinfomanagerbase;
+
+    function getnextnoncommentline(out s: string): boolean;
+   public
+
+     constructor create(const fn: tcmdstr; dest: twpoinfomanagerbase);
+     destructor destroy; override;
+
+     { processes the wpo info in the file }
+     procedure processfile;
+
+     { returns next line of the current section in s, and false if no more
+       lines in the current section
+     }
+     function sectiongetnextline(out s: string): boolean;
+  end;
+
+
+  { ************************************************************************* }
+  { ******* Specific kinds of whole program optimization components ********* }
+  { ************************************************************************* }
+
+  { method devirtualisation }
+  twpodevirtualisationhandler = class(twpocomponentbase)
+    { checks whether procdef (a procdef for a virtual method) can be replaced with
+      a static call when it's called as objdef.procdef, and if so returns the
+      mangled name in staticname.
+    }
+    function staticnameforcallingvirtualmethod(objdef, procdef: tdef; out staticname: string): boolean; virtual; abstract;
+    { checks whether procdef (a procdef for a virtual method) can be replaced with
+      a different procname in the vmt of objdef, and if so returns the new
+      mangledname in staticname
+    }
+    function staticnameforvmtentry(objdef, procdef: tdef; out staticname: string): boolean; virtual; abstract;
+  end;
+
+  twpodeadcodehandler = class(twpocomponentbase)
+    { checks whether a mangledname was removed as dead code from the final
+      binary (WARNING: must *not* be called for functions marked as inline,
+      since if all call sites are inlined, it won't appear in the final
+      binary but nevertheless is still necessary!)
+    }
+    function symbolinfinalbinary(const s: shortstring): boolean; virtual; abstract;
+  end;
+
+
+  { ************************************************************************* }
+  { ************ Collection of all instances of wpo components ************** }
+  { ************************************************************************* }
+
+  { class doing all the bookkeeping for everything  }
+
+  twpoinfomanagerbase = class
+   private
+    { array of classrefs of handler classes for the various kinds of whole
+      program optimizations that we support
+    }
+    fwpocomponents: tfphashlist;
+
+    freader: twpofilereader;
+    fwriter: twpofilewriter;
+   public
+    { instances of the various optimizers/information collectors (for
+      information used during this compilation)
+    }
+    wpoinfouse: array[twpotype] of twpocomponentbase;
+
+    { register a whole program optimization class type }
+    procedure registerwpocomponentclass(wpocomponent: twpocomponentbaseclass);
+
+    { get the program optimization class type that can parse the contents
+      of the section with name "secname" in the wpo feedback file
+    }
+    function gethandlerforsection(const secname: string): twpocomponentbaseclass;
+
+    { tell all instantiated wpo component classes to collect the information
+      from the global compiler state that they need (done at the very end of
+      the compilation process)
+    }
+    procedure extractwpoinfofromprogram;
+
+    { set the name of the feedback file from which all whole-program information
+      to be used during the current compilation will be read
+    }
+    procedure setwpoinputfile(const fn: tcmdstr);
+
+    { set the name of the feedback file to which all whole-program information
+      collected during the current compilation will be written
+    }
+    procedure setwpooutputfile(const fn: tcmdstr);
+
+    { check whether the specified wpo options (-FW/-Fw/-OW/-Ow) are complete
+      and sensical, and parse the wpo feedback file specified with
+      setwpoinputfile
+    }
+    procedure parseandcheckwpoinfo;
+
+    { routines accessing the optimizer information }
+    { 1) devirtualization at the symbol name level }
+    function can_be_devirtualized(objdef, procdef: tdef; out name: shortstring): boolean; virtual; abstract;
+    { 2) optimal replacement method name in vmt }
+    function optimized_name_for_vmt(objdef, procdef: tdef; out name: shortstring): boolean; virtual; abstract;
+    { 3) does a symbol appear in the final binary (i.e., not removed by dead code stripping/smart linking).
+        WARNING: do *not* call for inline functions/procedures/methods/...
+    }
+    function symbol_live(const name: shortstring): boolean; virtual; abstract;
+
+    constructor create; reintroduce;
+    destructor destroy; override;
+  end;
+
+
+  var
+    wpoinfomanager: twpoinfomanagerbase;
+
+implementation
+
+  uses
+    globals,
+    cutils,
+    sysutils,
+    symdef,
+    verbose;
+
+
+  { tcreatedwpoinfobase }
+
+  constructor tunitwpoinfobase.create;
+    begin
+      fcreatedobjtypes:=tfpobjectlist.create(false);
+      fcreatedclassrefobjtypes:=tfpobjectlist.create(false);
+      fmaybecreatedbyclassrefdeftypes:=tfpobjectlist.create(false);
+    end;
+
+
+  destructor tunitwpoinfobase.destroy;
+    begin
+      fcreatedobjtypes.free;
+      fcreatedobjtypes:=nil;
+      fcreatedclassrefobjtypes.free;
+      fcreatedclassrefobjtypes:=nil;
+      fmaybecreatedbyclassrefdeftypes.free;
+      fmaybecreatedbyclassrefdeftypes:=nil;
+      inherited destroy;
+    end;
+    
+    
+  procedure tunitwpoinfobase.addcreatedobjtype(def: tdef);
+    begin
+      fcreatedobjtypes.add(def);
+    end;
+
+  procedure tunitwpoinfobase.addcreatedobjtypeforclassref(def: tdef);
+    begin
+      fcreatedclassrefobjtypes.add(def);
+    end;
+
+  procedure tunitwpoinfobase.addmaybecreatedbyclassref(def: tdef);
+    begin
+      fmaybecreatedbyclassrefdeftypes.add(def);
+    end;
+
+  { twpofilereader }
+
+  function twpofilereader.getnextnoncommentline(out s: string):
+    boolean;
+    begin
+      if (fusecurline) then
+        begin
+          s:=fcurline;
+          fusecurline:=false;
+          result:=true;
+          exit;
+        end;
+      repeat
+        readln(finputfile,s);
+        if (s='') and
+           eof(finputfile) then
+          begin
+            result:=false;
+            exit;
+          end;
+        inc(flinenr);
+      until (s='') or
+            (s[1]<>'#');
+      result:=true;
+    end;
+
+  constructor twpofilereader.create(const fn: tcmdstr; dest: twpoinfomanagerbase);
+    begin
+      if not FileExists(fn) then
+        begin
+          cgmessage1(wpo_cant_find_file,fn);
+          exit;
+        end;
+      assign(finputfile,fn);
+      ffilename:=fn;
+
+      fdest:=dest;
+    end;
+
+  destructor twpofilereader.destroy;
+    begin
+      inherited destroy;
+    end;
+
+  procedure twpofilereader.processfile;
+    var
+      sectionhandler: twpocomponentbaseclass;
+      i: longint;
+      wpotype: twpotype;
+      s,
+      sectionname: string;
+    begin
+      cgmessage1(wpo_begin_processing,ffilename);
+      reset(finputfile);
+      flinenr:=0;
+      while getnextnoncommentline(s) do
+        begin
+          if (s='') then
+            continue;
+          { format: "% sectionname" }
+          if (s[1]<>'%') then
+            begin
+              cgmessage2(wpo_expected_section,tostr(flinenr),s);
+              break;
+            end;
+          for i:=2 to length(s) do
+            if (s[i]<>' ') then
+              break;
+          sectionname:=copy(s,i,255);
+
+          { find handler for section and process }
+          sectionhandler:=fdest.gethandlerforsection(sectionname);
+          if assigned(sectionhandler) then
+            begin
+              wpotype:=sectionhandler.getwpotype;
+              cgmessage2(wpo_found_section,sectionname,wpo2str[wpotype]);
+              { do we need this information? }
+              if ((sectionhandler.performswpoforswitches * init_settings.dowpoptimizerswitches) <> []) then
+                begin
+                  { did some other section already generate this type of information? }
+                  if assigned(fdest.wpoinfouse[wpotype]) then
+                    begin
+                      cgmessage2(wpo_duplicate_wpotype,wpo2str[wpotype],sectionname);
+                      fdest.wpoinfouse[wpotype].free;
+                    end;
+                  { process the section }
+                  fdest.wpoinfouse[wpotype]:=sectionhandler.create;
+                  twpocomponentbase(fdest.wpoinfouse[wpotype]).loadfromwpofilesection(self);
+                end
+              else
+                begin
+                  cgmessage1(wpo_skipping_unnecessary_section,sectionname);
+                  { skip the current section }
+                  while sectiongetnextline(s) do
+                    ;
+                end;
+            end
+          else
+            begin
+              cgmessage1(wpo_no_section_handler,sectionname);
+              { skip the current section }
+              while sectiongetnextline(s) do
+                ;
+            end;
+        end;
+      close(finputfile);
+      cgmessage1(wpo_end_processing,ffilename);
+    end;
+
+  function twpofilereader.sectiongetnextline(out s: string): boolean;
+    begin
+      result:=getnextnoncommentline(s);
+      if not result then
+        exit;
+      { start of new section? }
+      if (s<>'') and
+         (s[1]='%') then
+        begin
+          { keep read line for next call to getnextnoncommentline() }
+          fcurline:=s;
+          fusecurline:=true;
+          result:=false;
+        end;
+    end;
+
+
+  { twpocomponentbase }
+
+  constructor twpocomponentbase.create;
+    begin
+      { do nothing }
+    end;
+
+
+  class procedure twpocomponentbase.checkoptions;
+    begin
+      { do nothing }
+    end;
+
+  { twpofilewriter }
+
+  constructor twpofilewriter.create(const fn: tcmdstr);
+    begin
+      assign(foutputfile,fn);
+      ffilename:=fn;
+      fsectioncontents:=tfpobjectlist.create(true);
+    end;
+
+  destructor twpofilewriter.destroy;
+    begin
+      fsectioncontents.free;
+      inherited destroy;
+    end;
+
+  procedure twpofilewriter.writefile;
+    var
+      i: longint;
+    begin
+{$i-}
+      rewrite(foutputfile);
+{$i+}
+      if (ioresult <> 0) then
+        begin
+          cgmessage1(wpo_cant_create_feedback_file,ffilename);
+          exit;
+        end;
+      for i:=0 to fsectioncontents.count-1 do
+        twpocomponentbase(fsectioncontents[i]).storewpofilesection(self);
+      close(foutputfile);
+    end;
+
+  procedure twpofilewriter.startsection(const name: string);
+    begin
+      writeln(foutputfile,'% ',name);
+    end;
+
+  procedure twpofilewriter.sectionputline(const s: string);
+    begin
+      writeln(foutputfile,s);
+    end;
+
+  procedure twpofilewriter.registerwpocomponent(
+    component: twpocomponentbase);
+    begin
+      fsectioncontents.add(component);
+    end;
+
+{ twpoinfomanagerbase }
+
+  procedure twpoinfomanagerbase.registerwpocomponentclass(wpocomponent: twpocomponentbaseclass);
+    begin
+      fwpocomponents.add(wpocomponent.sectionname,wpocomponent);
+    end;
+
+
+  function twpoinfomanagerbase.gethandlerforsection(const secname: string
+      ): twpocomponentbaseclass;
+    begin
+      result:=twpocomponentbaseclass(fwpocomponents.find(secname));
+    end;
+
+  procedure twpoinfomanagerbase.setwpoinputfile(const fn: tcmdstr);
+    begin
+      freader:=twpofilereader.create(fn,self);
+    end;
+
+  procedure twpoinfomanagerbase.setwpooutputfile(const fn: tcmdstr);
+    begin
+      fwriter:=twpofilewriter.create(fn);
+    end;
+
+  procedure twpoinfomanagerbase.parseandcheckwpoinfo;
+    var
+      i: longint;
+    begin
+      { error if we don't have to optimize yet have an input feedback file }
+      if (init_settings.dowpoptimizerswitches=[]) and
+         assigned(freader) then
+        begin
+          cgmessage(wpo_input_without_info_use);
+          exit;
+        end;
+
+      { error if we have to optimize yet don't have an input feedback file }
+      if (init_settings.dowpoptimizerswitches<>[]) and
+         not assigned(freader) then
+        begin
+          cgmessage(wpo_no_input_specified);
+          exit;
+        end;
+
+      { if we have to generate wpo information, check that a file has been
+        specified and that we have something to write to it
+      }
+      if (init_settings.genwpoptimizerswitches<>[]) and
+         not assigned(fwriter) then
+        begin
+          cgmessage(wpo_no_output_specified);
+          exit;
+        end;
+
+      if (init_settings.genwpoptimizerswitches=[]) and
+         assigned(fwriter) then
+        begin
+          cgmessage(wpo_output_without_info_gen);
+          exit;
+        end;
+
+      { now read the input feedback file }
+      if assigned(freader) then
+        begin
+          freader.processfile;
+          freader.free;
+          freader:=nil;
+        end;
+
+      { and for each specified optimization check whether the input feedback
+        file contained the necessary information
+      }
+      if (([cs_wpo_devirtualize_calls,cs_wpo_optimize_vmts] * init_settings.dowpoptimizerswitches) <> []) and
+         not assigned(wpoinfouse[wpo_devirtualization_context_insensitive]) then
+        begin
+          cgmessage1(wpo_not_enough_info,wpo2str[wpo_devirtualization_context_insensitive]);
+          exit;
+        end;
+
+      if (cs_wpo_symbol_liveness in init_settings.dowpoptimizerswitches) and
+         not assigned(wpoinfouse[wpo_live_symbol_information]) then
+        begin
+          cgmessage1(wpo_not_enough_info,wpo2str[wpo_live_symbol_information]);
+          exit;
+        end;
+
+      { perform pre-checking to ensure there are no known incompatibilities between
+        the selected optimizations and other switches
+      }
+      for i:=0 to fwpocomponents.count-1 do
+        if (twpocomponentbaseclass(fwpocomponents[i]).generatesinfoforwposwitches*init_settings.genwpoptimizerswitches)<>[] then
+          twpocomponentbaseclass(fwpocomponents[i]).checkoptions
+    end;
+
+  procedure twpoinfomanagerbase.extractwpoinfofromprogram;
+    var
+      i: longint;
+      info: twpocomponentbase;
+    begin
+      { if don't have to write anything, fwriter has not been created }
+      if not assigned(fwriter) then
+        exit;
+
+      { let all wpo components gather the necessary info from the compiler state }
+      for i:=0 to fwpocomponents.count-1 do
+        if (twpocomponentbaseclass(fwpocomponents[i]).generatesinfoforwposwitches*current_settings.genwpoptimizerswitches)<>[] then
+          begin
+            info:=twpocomponentbaseclass(fwpocomponents[i]).create;
+            info.constructfromcompilerstate;
+            fwriter.registerwpocomponent(info);
+          end;
+      { and write their info to disk }
+      fwriter.writefile;
+      fwriter.free;
+      fwriter:=nil;
+    end;
+
+  constructor twpoinfomanagerbase.create;
+    begin
+      inherited create;
+      fwpocomponents:=tfphashlist.create;
+    end;
+
+  destructor twpoinfomanagerbase.destroy;
+    var
+      i: twpotype;
+    begin
+      freader.free;
+      freader:=nil;
+      fwriter.free;
+      fwriter:=nil;
+      fwpocomponents.free;
+      fwpocomponents:=nil;
+      for i:=low(wpoinfouse) to high(wpoinfouse) do
+        if assigned(wpoinfouse[i]) then
+          wpoinfouse[i].free;
+      inherited destroy;
+    end;
+
+end.

compiler/wpoinfo.pas

@@ -0,0 +1,250 @@
+{
+    Copyright (c) 2008 by Jonas Maebe
+
+    Whole program optimisation information collection
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License
+    along with this program; if not, write to the Free Software
+    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+ ****************************************************************************
+}
+
+unit wpoinfo;
+
+{$i fpcdefs.inc}
+
+interface
+
+uses
+  cclasses,
+  symtype,
+  wpobase,
+  ppu;
+
+type
+  pderefarray = ^tderefarray;
+  tderefarray = array[0..1024*1024-1] of tderef;
+
+  tunitwpoinfo = class(tunitwpoinfobase)
+   { devirtualisation information -- begin }
+   private
+    fcreatedobjtypesderefs: pderefarray;
+    fcreatedclassrefobjtypesderefs: pderefarray;
+    fmaybecreatedbyclassrefdeftypesderefs: pderefarray;
+   { devirtualisation information -- end }
+
+   public
+
+    destructor destroy; override;
+
+    procedure ppuwrite(ppufile:tcompilerppufile);
+    constructor ppuload(ppufile:tcompilerppufile);
+
+    procedure deref;
+    procedure derefimpl;
+    procedure buildderef;
+    procedure buildderefimpl;
+  end;
+
+
+  { twpoinfomanager }
+
+  twpoinfomanager = class(twpoinfomanagerbase)
+    function can_be_devirtualized(objdef, procdef: tdef; out name: shortstring): boolean; override;
+    function optimized_name_for_vmt(objdef, procdef: tdef; out name: shortstring): boolean; override;
+    function symbol_live(const name: shortstring): boolean; override;
+  end;
+
+
+implementation
+
+  uses
+    globtype,
+    globals,
+    symdef,
+    verbose;
+
+
+  destructor tunitwpoinfo.destroy;
+    begin
+      if assigned(fcreatedobjtypesderefs) then
+        begin
+          freemem(fcreatedobjtypesderefs);
+          fcreatedobjtypesderefs:=nil;
+        end;
+      if assigned(fcreatedclassrefobjtypesderefs) then
+        begin
+          freemem(fcreatedclassrefobjtypesderefs);
+          fcreatedclassrefobjtypesderefs:=nil;
+        end;
+      if assigned(fmaybecreatedbyclassrefdeftypesderefs) then
+        begin
+          freemem(fmaybecreatedbyclassrefdeftypesderefs);
+          fmaybecreatedbyclassrefdeftypesderefs:=nil;
+        end;
+      inherited destroy;
+    end;
+    
+    
+  procedure tunitwpoinfo.ppuwrite(ppufile:tcompilerppufile);
+    var
+      i: longint;
+    begin
+      { write the number of instantiated object types in this module,
+        followed by the derefs of those types
+      }
+      ppufile.putlongint(fcreatedobjtypes.count);
+      for i:=0 to fcreatedobjtypes.count-1 do
+        ppufile.putderef(fcreatedobjtypesderefs^[i]);
+      ppufile.putlongint(fcreatedclassrefobjtypes.count);
+      for i:=0 to fcreatedclassrefobjtypes.count-1 do
+        ppufile.putderef(fcreatedclassrefobjtypesderefs^[i]);
+      ppufile.putlongint(fmaybecreatedbyclassrefdeftypes.count);
+      for i:=0 to fmaybecreatedbyclassrefdeftypes.count-1 do
+        ppufile.putderef(fmaybecreatedbyclassrefdeftypesderefs^[i]);
+
+      ppufile.writeentry(ibcreatedobjtypes);
+
+      freemem(fcreatedobjtypesderefs);
+      fcreatedobjtypesderefs:=nil;
+      freemem(fcreatedclassrefobjtypesderefs);
+      fcreatedclassrefobjtypesderefs:=nil;
+      freemem(fmaybecreatedbyclassrefdeftypesderefs);
+      fmaybecreatedbyclassrefdeftypesderefs:=nil;
+    end;
+
+
+  constructor tunitwpoinfo.ppuload(ppufile:tcompilerppufile);
+    var
+      i, len: longint;
+    begin
+      { load start of definition section, which holds the amount of defs }
+      if ppufile.readentry<>ibcreatedobjtypes then
+        cgmessage(unit_f_ppu_read_error);
+
+      len:=ppufile.getlongint;
+      fcreatedobjtypes:=tfpobjectlist.create(false);
+      fcreatedobjtypes.count:=len;
+      getmem(fcreatedobjtypesderefs,len*sizeof(tderef));
+      for i:=0 to len-1 do
+        ppufile.getderef(fcreatedobjtypesderefs^[i]);
+
+      len:=ppufile.getlongint;
+      fcreatedclassrefobjtypes:=tfpobjectlist.create(false);
+      fcreatedclassrefobjtypes.count:=len;
+      getmem(fcreatedclassrefobjtypesderefs,len*sizeof(tderef));
+      for i:=0 to len-1 do
+        ppufile.getderef(fcreatedclassrefobjtypesderefs^[i]);
+
+      len:=ppufile.getlongint;
+      fmaybecreatedbyclassrefdeftypes:=tfpobjectlist.create(false);
+      fmaybecreatedbyclassrefdeftypes.count:=len;
+      getmem(fmaybecreatedbyclassrefdeftypesderefs,len*sizeof(tderef));
+      for i:=0 to len-1 do
+        ppufile.getderef(fmaybecreatedbyclassrefdeftypesderefs^[i]);
+    end;
+
+
+  procedure tunitwpoinfo.buildderef;
+    var
+      i: longint;
+    begin
+      getmem(fcreatedobjtypesderefs,fcreatedobjtypes.count*sizeof(tderef));
+      for i:=0 to fcreatedobjtypes.count-1 do
+        fcreatedobjtypesderefs^[i].build(fcreatedobjtypes[i]);
+
+      getmem(fcreatedclassrefobjtypesderefs,fcreatedclassrefobjtypes.count*sizeof(tderef));
+      for i:=0 to fcreatedclassrefobjtypes.count-1 do
+        fcreatedclassrefobjtypesderefs^[i].build(fcreatedclassrefobjtypes[i]);
+
+      getmem(fmaybecreatedbyclassrefdeftypesderefs,fmaybecreatedbyclassrefdeftypes.count*sizeof(tderef));
+      for i:=0 to fmaybecreatedbyclassrefdeftypes.count-1 do
+        fmaybecreatedbyclassrefdeftypesderefs^[i].build(fmaybecreatedbyclassrefdeftypes[i]);
+    end;
+
+
+  procedure tunitwpoinfo.buildderefimpl;
+    begin
+    end;
+
+
+  procedure tunitwpoinfo.deref;
+    var
+      i: longint;
+    begin
+      for i:=0 to fcreatedobjtypes.count-1 do
+        fcreatedobjtypes[i]:=fcreatedobjtypesderefs^[i].resolve;
+      freemem(fcreatedobjtypesderefs);
+      fcreatedobjtypesderefs:=nil;
+
+      for i:=0 to fcreatedclassrefobjtypes.count-1 do
+        fcreatedclassrefobjtypes[i]:=fcreatedclassrefobjtypesderefs^[i].resolve;
+      freemem(fcreatedclassrefobjtypesderefs);
+      fcreatedclassrefobjtypesderefs:=nil;
+
+      for i:=0 to fmaybecreatedbyclassrefdeftypes.count-1 do
+        fmaybecreatedbyclassrefdeftypes[i]:=fmaybecreatedbyclassrefdeftypesderefs^[i].resolve;
+      freemem(fmaybecreatedbyclassrefdeftypesderefs);
+      fmaybecreatedbyclassrefdeftypesderefs:=nil;
+    end;
+
+
+  procedure tunitwpoinfo.derefimpl;
+    begin
+    end;
+
+
+  { twpoinfomanager }
+
+  { devirtualisation }
+
+  function twpoinfomanager.can_be_devirtualized(objdef, procdef: tdef; out name: shortstring): boolean;
+    begin
+      if not assigned(wpoinfouse[wpo_devirtualization_context_insensitive]) or
+         not(cs_wpo_devirtualize_calls in current_settings.dowpoptimizerswitches) then
+        begin
+          result:=false;
+          exit;
+        end;
+      result:=twpodevirtualisationhandler(wpoinfouse[wpo_devirtualization_context_insensitive]).staticnameforcallingvirtualmethod(objdef,procdef,name);
+    end;
+
+
+  function twpoinfomanager.optimized_name_for_vmt(objdef, procdef: tdef; out name: shortstring): boolean;
+    begin
+      if not assigned(wpoinfouse[wpo_devirtualization_context_insensitive]) or
+         not(cs_wpo_optimize_vmts in current_settings.dowpoptimizerswitches) then
+        begin
+          result:=false;
+          exit;
+        end;
+      result:=twpodevirtualisationhandler(wpoinfouse[wpo_devirtualization_context_insensitive]).staticnameforvmtentry(objdef,procdef,name);
+    end;
+
+
+  { symbol liveness }
+
+  function twpoinfomanager.symbol_live(const name: shortstring): boolean;
+    begin
+      if not assigned(wpoinfouse[wpo_live_symbol_information]) or
+         not(cs_wpo_symbol_liveness in current_settings.dowpoptimizerswitches) then
+        begin
+          { if we don't know, say that the symbol is live }
+          result:=true;
+          exit;
+        end;
+      result:=twpodeadcodehandler(wpoinfouse[wpo_live_symbol_information]).symbolinfinalbinary(name);
+    end;
+
+
+end.

tests/readme.txt

@@ -85,6 +85,13 @@ KNOWNCOMPILEERROR..Known bug, which manifest itself at compile time. To
                    from compiler, followed by an optional note. Will not
                    be logged as a bug.
 QUICKTEST..........If set, only tests without package dependencies are executed
+WPOPARAS...........Parameters to be added after -OW/-Ow to perform whole
+                   program optimization tests
+WPOPASSES..........Number of whole program optimization iterations to perform
+                   ("1" means compile once with "-FWsomefile -OW<wpoparas>"
+                    and then again with "-FWsomefile2 -OW<wpoparas>
+                    -Fwsomefile1 -Ow<wpoparas>", "2" means another pass but
+                   using somefile2 as input and somefile3 as output, etc.)
 
   NOTE: A list consists of comma separated items, e. g. CPU=i386,m68k,powerpc
         No space between the elements and the comma.

tests/test/opt/twpo1.pp

@@ -0,0 +1,62 @@
+{ %wpoparas=devirtcalls,optvmts }
+{ %wpopasses=1 }
+
+{$mode objfpc}
+
+{ check to make sure that classes created via classrefdefs are properly
+  registered
+}
+
+type
+  ta = class
+    constructor mycreate;
+    procedure test; virtual;
+    class procedure test2; virtual;
+  end;
+
+  tb = class(ta)
+    procedure test; override;
+    class procedure test2; override;
+  end;
+
+constructor ta.mycreate;
+begin
+end;
+
+procedure ta.test;
+begin
+  writeln('ta.test');
+  halt(1);
+end;
+
+
+class procedure ta.test2;
+begin
+  writeln('ta.test2');
+end;
+
+
+var
+ cc: class of ta;
+
+
+procedure tb.test;
+begin
+  writeln('tb.test');
+end;
+
+class procedure tb.test2;
+begin
+  cc:=self;
+  writeln('tb.test2');
+end;
+
+var
+  a: ta;
+  ca: class of ta;
+begin
+  tb.test2;
+  a:=cc.create;
+  a.test;
+  a.free
+end.

tests/test/opt/twpo2.pp

@@ -0,0 +1,19 @@
+{ %wpoparas=devirtcalls,optvmts }
+{ %wpopasses=1 }
+
+{$mode objfpc}
+
+{ same as two1, except with a unit to test loading wpo info from a ppu file }
+
+uses
+  uwpo2;
+
+var
+  a: ta;
+  ca: class of ta;
+begin
+  tb.test2;
+  a:=cc.create;
+  a.test;
+  a.free
+end.

tests/test/opt/twpo3.pp

@@ -0,0 +1,54 @@
+{ %wpoparas=devirtcalls,optvmts }
+{ %wpopasses=1 }
+
+{$mode objfpc}
+
+{ check that multiple descendents properly mark parent class method as
+  non-optimisable
+}
+
+type
+  tbase = class
+    procedure test; virtual;
+  end;
+
+  tchild1 = class(tbase)
+    procedure test; override;
+  end;
+
+  tchild2 = class(tbase)
+    procedure test; override;
+  end;
+
+procedure tbase.test;
+begin
+  halt(1);
+end;
+
+var
+  a: longint;
+
+procedure tchild1.test;
+begin
+  if a<>1 then
+    halt(2);
+end;
+
+procedure tchild2.test;
+begin
+  if a<>2 then
+    halt(3);
+end;
+
+var
+  bb: tbase;
+begin
+  bb:=tchild1.create;
+  a:=1;
+  bb.test;
+  a:=2;
+  bb.free;
+  bb:=tchild2.create;
+  bb.test;
+  bb.free;
+end.

tests/test/opt/twpo4.pp

@@ -0,0 +1,66 @@
+{ %target=darwin,linux,freebsd,solaris }
+{ %wpoparas=devirtcalls,optvmts,symbolliveness }
+{ %wpopasses=2 }
+{ %opt=-CX -XX -Xs- }
+
+{ not enabled for windows yet because symbolliveness doesn't work there without
+  installing "nm" (until implemented by way of internal linker there)
+}
+
+{$mode objfpc}
+
+{ test case that can be optimised based on taking into account dead code
+  stripping
+}
+
+type
+  tbase = class
+    procedure test; virtual;
+  end;
+
+  tchild1 = class(tbase)
+    procedure test; override;
+  end;
+
+  tchild2 = class(tbase)
+    procedure test; override;
+  end;
+
+procedure tbase.test;
+begin
+  halt(1);
+end;
+
+var
+  a: longint;
+
+procedure tchild1.test;
+begin
+  if a<>1 then
+    halt(2);
+end;
+
+procedure tchild2.test;
+begin
+  if a<>2 then
+    halt(3);
+end;
+
+procedure notcalled;
+var
+  bb: tbase;
+begin
+  bb:=tchild2.create;
+  bb.test;
+  bb.free;
+end;
+
+var
+  bb: tbase;
+begin
+  bb:=tchild1.create;
+  a:=1;
+  bb.test;
+  a:=2;
+  bb.free;
+end.

tests/test/opt/uwpo2.pp

@@ -0,0 +1,52 @@
+{$mode objfpc}
+unit uwpo2;
+
+interface
+
+type
+  ta = class
+    constructor mycreate;
+    procedure test; virtual;
+    class procedure test2; virtual;
+  end;
+
+  tb = class(ta)
+    procedure test; override;
+    class procedure test2; override;
+  end;
+
+var
+ cc: class of ta;
+
+implementation
+
+constructor ta.mycreate;
+begin
+end;
+
+procedure ta.test;
+begin
+  writeln('ta.test');
+  halt(1);
+end;
+
+
+class procedure ta.test2;
+begin
+  writeln('ta.test2');
+end;
+
+
+
+procedure tb.test;
+begin
+  writeln('tb.test');
+end;
+
+class procedure tb.test2;
+begin
+  cc:=self;
+  writeln('tb.test2');
+end;
+
+end.

tests/utils/dotest.pp

@@ -525,7 +525,10 @@ end;
 
 function RunCompiler:boolean;
 var
-  args    : string;
+  args,
+  wpoargs : string;
+  passnr,
+  passes  : longint;
   execres : boolean;
 begin
   RunCompiler:=false;
@@ -547,50 +550,66 @@ begin
 {$endif unix}
   if Config.NeedOptions<>'' then
    args:=args+' '+Config.NeedOptions;
+  wpoargs:='';
+  if (Config.WpoPasses=0) or
+     (Config.WpoParas='') then
+    passes:=1
+  else
+    passes:=config.wpopasses+1;
   args:=args+' '+ppfile;
-  Verbose(V_Debug,'Executing '+compilerbin+' '+args);
-  { also get the output from as and ld that writes to stderr sometimes }
-{$ifndef macos}
-  execres:=ExecuteRedir(CompilerBin,args,'',CompilerLogFile,'stdout');
-{$else macos}
-  {Due to that Toolserver is not reentrant, we have to asm and link via script.}
-  execres:=ExecuteRedir(CompilerBin,'-s '+args,'',CompilerLogFile,'stdout');
-  if execres then
-    execres:=ExecuteRedir(TestOutputDir + ':ppas','','',CompilerLogFile,'stdout');
-{$endif macos}
-  Verbose(V_Debug,'Exitcode '+ToStr(ExecuteResult));
 
-  { Error during execution? }
-  if (not execres) and (ExecuteResult=0) then
+  for passnr:=1 to passes do
     begin
-      AddLog(FailLogFile,TestName);
-      AddLog(ResLogFile,failed_to_compile+PPFileInfo);
-      AddLog(LongLogFile,line_separation);
-      AddLog(LongLogFile,failed_to_compile+PPFileInfo);
-      CopyFile(CompilerLogFile,LongLogFile,true);
-      { avoid to try again }
-      AddLog(ExeLogFile,failed_to_compile+PPFileInfo);
-      Verbose(V_Abort,'IOStatus: '+ToStr(IOStatus));
-      exit;
-    end;
+      if (passes>1) then
+        begin
+          wpoargs:=' -OW'+config.wpoparas+' -FW'+TestOutputFileName(ppfile,'wp'+tostr(passnr));
+          if (passnr>1) then
+            wpoargs:=wpoargs+' -Ow'+config.wpoparas+' -Fw'+TestOutputFileName(ppfile,'wp'+tostr(passnr-1));
+        end;
+      Verbose(V_Debug,'Executing '+compilerbin+' '+args+wpoargs);
+      { also get the output from as and ld that writes to stderr sometimes }
+    {$ifndef macos}
+      execres:=ExecuteRedir(CompilerBin,args+wpoargs,'',CompilerLogFile,'stdout');
+    {$else macos}
+      {Due to that Toolserver is not reentrant, we have to asm and link via script.}
+      execres:=ExecuteRedir(CompilerBin,'-s '+args+wpoargs,'',CompilerLogFile,'stdout');
+      if execres then
+        execres:=ExecuteRedir(TestOutputDir + ':ppas','','',CompilerLogFile,'stdout');
+    {$endif macos}
+      Verbose(V_Debug,'Exitcode '+ToStr(ExecuteResult));
+
+      { Error during execution? }
+      if (not execres) and (ExecuteResult=0) then
+        begin
+          AddLog(FailLogFile,TestName);
+          AddLog(ResLogFile,failed_to_compile+PPFileInfo);
+          AddLog(LongLogFile,line_separation);
+          AddLog(LongLogFile,failed_to_compile+PPFileInfo);
+          CopyFile(CompilerLogFile,LongLogFile,true);
+          { avoid to try again }
+          AddLog(ExeLogFile,failed_to_compile+PPFileInfo);
+          Verbose(V_Abort,'IOStatus: '+ToStr(IOStatus));
+          exit;
+        end;
 
-  { Check for internal error }
-  if ExitWithInternalError(CompilerLogFile) then
-   begin
-     AddLog(FailLogFile,TestName);
-     if Config.Note<>'' then
-      AddLog(FailLogFile,Config.Note);
-     AddLog(ResLogFile,failed_to_compile+PPFileInfo+' internalerror generated');
-     AddLog(LongLogFile,line_separation);
-     AddLog(LongLogFile,failed_to_compile+PPFileInfo);
-     if Config.Note<>'' then
-      AddLog(LongLogFile,Config.Note);
-     CopyFile(CompilerLogFile,LongLogFile,true);
-     { avoid to try again }
-     AddLog(ExeLogFile,'Failed to compile '+PPFileInfo);
-     Verbose(V_Abort,'Internal error in compiler');
-     exit;
-   end;
+      { Check for internal error }
+      if ExitWithInternalError(CompilerLogFile) then
+       begin
+         AddLog(FailLogFile,TestName);
+         if Config.Note<>'' then
+          AddLog(FailLogFile,Config.Note);
+         AddLog(ResLogFile,failed_to_compile+PPFileInfo+' internalerror generated');
+         AddLog(LongLogFile,line_separation);
+         AddLog(LongLogFile,failed_to_compile+PPFileInfo);
+         if Config.Note<>'' then
+          AddLog(LongLogFile,Config.Note);
+         CopyFile(CompilerLogFile,LongLogFile,true);
+         { avoid to try again }
+         AddLog(ExeLogFile,'Failed to compile '+PPFileInfo);
+         Verbose(V_Abort,'Internal error in compiler');
+         exit;
+       end;
+    end;
 
   { Should the compile fail ? }
   if Config.ShouldFail then

tests/utils/redir.pp

@@ -17,6 +17,7 @@
 Unit Redir;
 Interface
 
+{$H+}
 {$R-}
 {$ifndef Linux}
 {$ifndef Unix}
@@ -89,6 +90,10 @@ const
 
 Implementation
 
+{$ifdef macos}
+{$define usedos}
+{$endif}
+
 Uses
 {$ifdef go32v2}
   go32,
@@ -104,7 +109,11 @@ Uses
     unix,
   {$endif}
 {$endif unix}
+{$ifdef usedos}
   dos;
+{$else}
+  sysutils;
+{$endif}
 
 Const
 {$ifdef UNIX}
@@ -123,6 +132,31 @@ Const
 {$endif MACOS}
 {$endif UNIX}
 
+{$ifndef usedos}
+{ code from:                                                 }
+{ Lithuanian Text Tool version 0.9.0  (2001-04-19)           }
+{ Copyright (c) 1999-2001 Marius Gedminas <[email protected]> }
+{ (GPLv2 or later)                                           }
+
+function FExpand(const S: string): string;
+begin
+  FExpand := ExpandFileName(S);
+end;
+
+type
+  PathStr = string;
+  DirStr = string;
+  NameStr = string;
+  ExtStr = string;
+
+procedure FSplit(Path: PathStr; var Dir: DirStr; var Name: NameStr; var Ext: ExtStr);
+begin
+  Dir := ExtractFilePath(Path);
+  Name := ChangeFileExt(ExtractFileName(Path), '');
+  Ext := ExtractFileExt(Path);
+end;
+
+{$endif}
 
 var
   FIN,FOUT,FERR     : ^File;
@@ -142,12 +176,12 @@ var
   i : longint;
 begin
   { Fix separator }
+  setlength(fixpath,length(s));
   for i:=1 to length(s) do
    if s[i] in ['/','\'] then
     fixpath[i]:=DirSep
    else
     fixpath[i]:=s[i];
-  fixpath[0]:=s[0];
 end;
 
 
@@ -280,13 +314,19 @@ end;
 
 {$I-}
 function FileExist(const FileName : PathStr) : Boolean;
+{$ifdef usedos}
 var
   f : file;
   Attr : word;
+{$endif}
 begin
+{$ifdef usedos}
   Assign(f, FileName);
   GetFAttr(f, Attr);
   FileExist := DosError = 0;
+{$else}
+  FileExist := Sysutils.FileExists(filename);
+{$endif}
 end;
 
 function CompleteDir(const Path: string): string;
@@ -321,7 +361,11 @@ begin
       Exit;
     end;
 
+{$ifdef usedos}
   S:=GetEnv('PATH');
+{$else}
+  S:=GetEnvironmentVariable('PATH');
+{$endif}
   While Length(S)>0 do
     begin
       i:=1;
@@ -963,7 +1007,9 @@ end;
 {$IfDef MsDos}
   SmallHeap;
 {$EndIf MsDos}
+{$ifdef usedos}
     SwapVectors;
+{$endif usedos}
     { Must use shell() for linux for the wildcard expansion (PFV) }
 {$ifdef UNIX}
     IOStatus:=0;
@@ -991,12 +1037,12 @@ end;
   {$endif windows}
     DosError:=0;
     If UseComSpec then
-      Dos.Exec (Getenv('COMSPEC'),'/C '+FixPath(progname)+' '+Comline)
+      Sysutils.ExecuteProcess (Getenv('COMSPEC'),'/C '+FixPath(progname)+' '+Comline)
     else
       begin
         if LocateExeFile(progname) then
           {$ifndef macos}
-          Dos.Exec(ProgName,Comline)
+          Sysutils.ExecuteProcess(ProgName,Comline)
           {$else}
           Dos.Exec(''''+ProgName+'''',Comline) {Quotes needed !}
           {$endif}
@@ -1010,7 +1056,9 @@ end;
     IOStatus:=DosError;
     ExecuteResult:=DosExitCode;
 {$endif}
+{$ifdef usedos}
     SwapVectors;
+{$endif}
 {$ifdef CPU86}
     { reset the FPU }
     {$asmmode att}

tests/utils/testu.pp

@@ -38,6 +38,8 @@ type
     Category      : string;
     Note          : string;
     Files         : string;
+    WpoParas      : string;
+    WpoPasses     : longint;
   end;
 
 Const
@@ -263,6 +265,12 @@ begin
               else
                if GetEntry('FILES') then
                 r.Files:=res
+              else
+                if GetEntry('WPOPARAS') then
+                 r.wpoparas:=res
+              else
+                if GetEntry('WPOPASSES') then
+                 val(res,r.wpopasses,code)
               else
                Verbose(V_Error,'Unknown entry: '+s);
             end;