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;