From 060d81b8fac6a63c341459d50d60fa70d0175b3f Mon Sep 17 00:00:00 2001 From: Jonas Maebe Date: Thu, 11 Dec 2008 17:40:18 +0000 Subject: [PATCH] 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://jonas@svn.freepascal.org/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, -Ow, -FW and -Fw 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 | 10 + compiler/compiler.pas | 5 +- compiler/fmodule.pas | 49 +- compiler/fpcdefs.inc | 1 + compiler/fppu.pas | 53 +- compiler/globals.pas | 63 +++ compiler/globtype.pas | 16 + compiler/msg/errore.msg | 91 +++- compiler/msgidx.inc | 27 +- compiler/msgtxt.inc | 264 ++++++---- compiler/ncal.pas | 121 ++++- compiler/ncgcal.pas | 13 +- compiler/nmem.pas | 9 +- compiler/nobj.pas | 5 +- compiler/optdead.pas | 416 +++++++++++++++ compiler/options.pas | 50 ++ compiler/optvirt.pas | 1098 +++++++++++++++++++++++++++++++++++++++ compiler/pmodules.pas | 65 ++- compiler/ppu.pas | 4 +- compiler/symdef.pas | 86 ++- compiler/symtype.pas | 5 + compiler/wpo.pas | 79 +++ compiler/wpobase.pas | 680 ++++++++++++++++++++++++ compiler/wpoinfo.pas | 250 +++++++++ tests/readme.txt | 7 + tests/test/opt/twpo1.pp | 62 +++ tests/test/opt/twpo2.pp | 19 + tests/test/opt/twpo3.pp | 54 ++ tests/test/opt/twpo4.pp | 66 +++ tests/test/opt/uwpo2.pp | 52 ++ tests/utils/dotest.pp | 101 ++-- tests/utils/redir.pp | 54 +- tests/utils/testu.pp | 8 + 33 files changed, 3684 insertions(+), 199 deletions(-) create mode 100644 compiler/optdead.pas create mode 100644 compiler/optvirt.pas create mode 100644 compiler/wpo.pas create mode 100644 compiler/wpobase.pas create mode 100644 compiler/wpoinfo.pas create mode 100644 tests/test/opt/twpo1.pp create mode 100644 tests/test/opt/twpo2.pp create mode 100644 tests/test/opt/twpo3.pp create mode 100644 tests/test/opt/twpo4.pp create mode 100644 tests/test/opt/uwpo2.pp diff --git a/.gitattributes b/.gitattributes index caa14b7a99..73de787482 100644 --- a/.gitattributes +++ b/.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 diff --git a/compiler/compiler.pas b/compiler/compiler.pas index 3362bcf387..98c42e61f0 100644 --- a/compiler/compiler.pas +++ b/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; diff --git a/compiler/fmodule.pas b/compiler/fmodule.pas index 42d770cb7c..2d95a8f3de 100644 --- a/compiler/fmodule.pas +++ b/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; diff --git a/compiler/fpcdefs.inc b/compiler/fpcdefs.inc index bad010b951..df2f689031 100644 --- a/compiler/fpcdefs.inc +++ b/compiler/fpcdefs.inc @@ -3,6 +3,7 @@ {$H-} {$goto on} {$inline on} +{$interfaces corba} {$ifdef win32} { 256 MB stack } diff --git a/compiler/fppu.pas b/compiler/fppu.pas index 65b304271d..6fe7287533 100644 --- a/compiler/fppu.pas +++ b/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^); diff --git a/compiler/globals.pas b/compiler/globals.pas index d422306916..b9773789c5 100644 --- a/compiler/globals.pas +++ b/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; diff --git a/compiler/globtype.pas b/compiler/globtype.pas index bd320fcc34..5dbb1a578a 100644 --- a/compiler/globtype.pas +++ b/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', diff --git a/compiler/msg/errore.msg b/compiler/msg/errore.msg index 0b12d04a2f..9e563e7f55 100644 --- a/compiler/msg/errore.msg +++ b/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} \var{-OW}), +% 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_Set resource (.res) linker to **2Fu_Add to unit path **2FU_Set unit output path to , overrides -FE +**2FW_Store generated whole-program optimization feedback in +**2Fw_Load previously stored whole-program optimization feedback from *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=_Set alignment **2Oo[NO]_Enable or disable optimizations, see fpc -i for possible values **2Op_Set target cpu for optimizing, see fpc -i for possible values +**2OW_Generate whole-program optimization feedback for optimization , see fpc -i for possible values +**2Ow_Perform whole-program optimization , see fpc -i for possible values **2Os_Optimize for size rather than speed **1pg_Generate profile code for gprof (defines FPC_PROFILE) **1R_Assembler reading style: diff --git a/compiler/msgidx.inc b/compiler/msgidx.inc index ae79243f84..88f69944e4 100644 --- a/compiler/msgidx.inc +++ b/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 ); diff --git a/compiler/msgtxt.inc b/compiler/msgtxt.inc index ba200153f3..3a9aee7ee3 100644 --- a/compiler/msgtxt.inc +++ b/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] [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+ ' bugs@freepascal.org'#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_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_Code generation options:'#010+ '**2Ca_Select ABI, see fpc -i for possible values'#010+ '**2Cb_Generate big-endian code'#010+ '**2Cc_Set default calling convention to '#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_Select fpu instruction set to use, see fpc -i for possible va'+ 'lues'#010+ '**2CF_Minimal floating point constant precision (default, 32, 64)'#010+ '**2Cg_Generate PIC code'#010+ - '**2Ch','_ bytes heap (between 1023 and 67107840)'#010+ + '**','2Ch_ 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_Select instruction set, see fpc -i for pos','sible values'#010+ + '**2Cp_Select instruction set, see fpc -i for ','possible values'#010+ '**2CP=_ packing settings'#010+ '**3CPPACKSET=_ 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_Set stack size to '#010+ '**2Ct_Stack checking'#010+ - '**2CX_','Create also smartlinked library'#010+ + '**2','CX_Create also smartlinked library'#010+ '**1d_Defines the symbol '#010+ '**1D_Generate a DEF file'#010+ '**2Dd_Set description to '#010+ @@ -938,204 +984,212 @@ const msgtxt : array[0..000198,1..240] of char=( '*O2Dw_PM application'#010+ '**1e_Set path to executable'#010+ '**1E_Same as -Cn'#010+ - '**1fPIC_Same as -Cg',#010+ + '**1fPIC_Same as ','-Cg'#010+ '**1F_Set file names and paths:'#010+ '**2Fa[,y]_(for a program) load units and [y] before uses is par'+ 'sed'#010+ '**2Fc_Set input codepage to '#010+ '**2FC_Set RC compiler binary name to '#010+ - '**2FD_Set the directory where to search for compi','ler utilities'#010+ + '**2FD_Set the directory where to search for co','mpiler utilities'#010+ '**2Fe_Redirect error output to '#010+ '**2Ff_Add to framework path (Darwin only)'#010+ '**2FE_Set exe/unit output path to '#010+ '**2Fi_Add to include path'#010+ '**2Fl_Add to library path'#010+ - '**2FL_Use as dynamic link','er'#010+ + '**2FL_Use as dynamic l','inker'#010+ '**2Fm_Load unicode conversion table from .txt in the compiler di'+ 'r'#010+ '**2Fo_Add to object path'#010+ '**2Fr_Load error message file '#010+ '**2FR_Set resource (.res) linker to '#010+ '**2Fu_Add to unit path'#010+ - '**2FU_Set unit outpu','t path to , overrides -FE'#010+ + '**2FU_Set unit ou','tput path to , overrides -FE'#010+ + '**2FW_Store generated whole-program optimization feedback in '#010+ + '**2Fw_Load previously stored whole-program optimization feedback fr'+ + 'om '#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_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_Add to include path'#010+ - '**1k_Pa','ss to the linker'#010+ + '**1k_Pass to the linker'#010+ '**1l_Write logo'#010+ '**1M_Set language mode to '#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_Node tree optimizations'#010+ + '**1N','_Node tree optimizations'#010+ '**2Nu_Unroll loops'#010+ '**1o_Change the name of the executable produced to '#010+ '**1O_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=_Set alignment'#010+ - '**2Oo[NO]_Enable or disable optim','izations, see fpc -i for possibl'+ - 'e values'#010+ - '**2Op_Set target cpu for optimizing, see fpc -i for possible values'+ - #010+ - '**2Os_Optimize for size rather than speed'#010+ + '**2Oo[NO]_Enable or disable optimizations, see fpc -i for possible '+ + 'values'#010+ + '**2Op_Set target cpu for optimizing, see fpc -i ','for possible valu'+ + 'es'#010+ + '**2OW_Generate whole-program optimization feedback for optimization'+ + ' , see fpc -i for possible values'#010+ + '**2Ow_Perform whole-program optimization , 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_Assembler reading ','style:'#010+ + '**1R_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_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_Error options. is a combination of the following:'#010+ - '**3*_ : Compiler halts after the errors (default is 1)'#010+ + '**3*_ : Compil','er halts after the 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_Set interface style to '#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_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_Undefines the symbol '#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_Be verbose. 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, : Don'#039't show messages numbered and '#010+ + '**2*_m,',' : Don'#039't show messages numbered and '#010+ '3*1W_Target-specific options (targets)'#010+ - 'A*1W_T','arget-specific options (targets)'#010+ + 'A*1W_Target-specific options (targets)'#010+ 'P*1W_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_Set the name of the '#039'main'#039' program routine (default i'+ 's '#039'main'#039')'#010+ - '**2XP_Prepend the binutils names with the prefix '#010+ - '**2Xr_Set library search path to (needed fo','r cross compile) ('+ - 'BeOS, Linux)'#010+ + '**2XP_Pr','epend the binutils names with the prefix '#010+ + '**2Xr_Set library search path to (needed for cross compile) (Be'+ + 'OS, Linux)'#010+ '**2XR_Prepend 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' ); diff --git a/compiler/ncal.pas b/compiler/ncal.pas index 7fc0200926..f82aa7274c 100644 --- a/compiler/ncal.pas +++ b/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 .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 diff --git a/compiler/ncgcal.pas b/compiler/ncgcal.pas index 79d17f36b0..596f112a08 100644 --- a/compiler/ncgcal.pas +++ b/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; diff --git a/compiler/nmem.pas b/compiler/nmem.pas index 2df832392a..9874fc14d6 100644 --- a/compiler/nmem.pas +++ b/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; diff --git a/compiler/nobj.pas b/compiler/nobj.pas index d02b3804d4..b08bd5b3a2 100644 --- a/compiler/nobj.pas +++ b/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} diff --git a/compiler/optdead.pas b/compiler/optdead.pas new file mode 100644 index 0000000000..d73c8ac6ee --- /dev/null +++ b/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. + diff --git a/compiler/options.pas b/compiler/options.pas index af8890eb44..331b6be3b5 100644 --- a/compiler/options.pas +++ b/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; diff --git a/compiler/optvirt.pas b/compiler/optvirt.pas new file mode 100644 index 0000000000..bd84839d73 --- /dev/null +++ b/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. diff --git a/compiler/pmodules.pas b/compiler/pmodules.pas index f7d67d9c57..eeec81661e 100644 --- a/compiler/pmodules.pas +++ b/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 diff --git a/compiler/ppu.pas b/compiler/ppu.pas index 452315c024..fa6ebf2a67 100644 --- a/compiler/ppu.pas +++ b/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 } diff --git a/compiler/symdef.pas b/compiler/symdef.pas index 681d78c1e3..2fe56c94a4 100644 --- a/compiler/symdef.pas +++ b/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,7 +2062,19 @@ 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 ****************************************************************************} diff --git a/compiler/symtype.pas b/compiler/symtype.pas index 34c9a3f3a4..44298e88d6 100644 --- a/compiler/symtype.pas +++ b/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) ****************************************************************************} diff --git a/compiler/wpo.pas b/compiler/wpo.pas new file mode 100644 index 0000000000..1d3cf4d6e4 --- /dev/null +++ b/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. + diff --git a/compiler/wpobase.pas b/compiler/wpobase.pas new file mode 100644 index 0000000000..25674eabe8 --- /dev/null +++ b/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. diff --git a/compiler/wpoinfo.pas b/compiler/wpoinfo.pas new file mode 100644 index 0000000000..536cf541eb --- /dev/null +++ b/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. diff --git a/tests/readme.txt b/tests/readme.txt index eeee23e592..8775e817ff 100644 --- a/tests/readme.txt +++ b/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" + and then again with "-FWsomefile2 -OW + -Fwsomefile1 -Ow", "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. diff --git a/tests/test/opt/twpo1.pp b/tests/test/opt/twpo1.pp new file mode 100644 index 0000000000..1c2756ef09 --- /dev/null +++ b/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. diff --git a/tests/test/opt/twpo2.pp b/tests/test/opt/twpo2.pp new file mode 100644 index 0000000000..0f885ea067 --- /dev/null +++ b/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. diff --git a/tests/test/opt/twpo3.pp b/tests/test/opt/twpo3.pp new file mode 100644 index 0000000000..b8979731b5 --- /dev/null +++ b/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. diff --git a/tests/test/opt/twpo4.pp b/tests/test/opt/twpo4.pp new file mode 100644 index 0000000000..9d42aa980d --- /dev/null +++ b/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. diff --git a/tests/test/opt/uwpo2.pp b/tests/test/opt/uwpo2.pp new file mode 100644 index 0000000000..350d275825 --- /dev/null +++ b/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. diff --git a/tests/utils/dotest.pp b/tests/utils/dotest.pp index 3e0d5b1861..61cb8d79a2 100644 --- a/tests/utils/dotest.pp +++ b/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)); - { 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; + { 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; + end; { Should the compile fail ? } if Config.ShouldFail then diff --git a/tests/utils/redir.pp b/tests/utils/redir.pp index 215a6d852f..a33cb4f093 100644 --- a/tests/utils/redir.pp +++ b/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 } +{ (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} diff --git a/tests/utils/testu.pp b/tests/utils/testu.pp index 8f8a86b828..bded7b3e8e 100644 --- a/tests/utils/testu.pp +++ b/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;