{ $Id$ Copyright (c) 1998-2002 by Florian Klaempfl, Daniel Mantione Does the parsing and codegeneration at subroutine level 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 psub; {$i fpcdefs.inc} interface uses cclasses,globals, node,nbas, symdef,procinfo; type tcgprocinfo = class(tprocinfo) private procedure add_entry_exit_code; public { code for the subroutine as tree } code : tnode; { positions in the tree for init/final } entry_asmnode, loadpara_asmnode, exitlabel_asmnode, stackcheck_asmnode, init_asmnode, final_asmnode : tasmnode; { list to store the procinfo's of the nested procedures } nestedprocs : tlinkedlist; constructor create(aparent:tprocinfo);override; destructor destroy;override; procedure printproc; procedure generate_code; procedure resetprocdef; procedure add_to_symtablestack; procedure remove_from_symtablestack; procedure parse_body; end; procedure printnode_reset; { reads the declaration blocks } procedure read_declarations(islibrary : boolean); { reads declarations in the interface part of a unit } procedure read_interface_declarations; implementation uses { common } cutils, { global } globtype,tokens,verbose,comphook, systems, { aasm } cpubase,aasmbase,aasmtai, { symtable } symconst,symbase,symsym,symtype,symtable,defutil, paramgr, ppu,fmodule, { pass 1 } nutils,nld,ncal,ncon,nflw,nadd,ncnv,nmem, pass_1, {$ifdef state_tracking} nstate, {$endif state_tracking} { pass 2 } {$ifndef NOPASS2} pass_2, {$endif} { parser } scanner,import,gendef, pbase,pstatmnt,pdecl,pdecsub,pexports, { codegen } tgobj,cgobj, ncgutil,regvars {$ifdef arm} ,aasmcpu {$endif arm} {$ifndef NOOPT} {$ifdef i386} ,aopt386 {$else i386} ,aopt {$endif i386} {$endif} ; {**************************************************************************** PROCEDURE/FUNCTION BODY PARSING ****************************************************************************} procedure initializevars(p:tnamedindexitem;arg:pointer); var b : tblocknode; begin if not (tsym(p).typ in [localvarsym,globalvarsym]) then exit; with tabstractnormalvarsym(p) do begin if assigned(defaultconstsym) then begin b:=tblocknode(arg); b.left:=cstatementnode.create( cassignmentnode.create( cloadnode.create(tsym(p),tsym(p).owner), cloadnode.create(defaultconstsym,defaultconstsym.owner)), b.left); end; end; end; procedure check_finalize_paras(p : tnamedindexitem;arg:pointer); begin if (tsym(p).typ=paravarsym) and (tparavarsym(p).varspez=vs_value) and not is_class(tparavarsym(p).vartype.def) and tparavarsym(p).vartype.def.needs_inittable then include(current_procinfo.flags,pi_needs_implicit_finally); end; procedure check_finalize_locals(p : tnamedindexitem;arg:pointer); begin if (tsym(p).typ=localvarsym) and (tlocalvarsym(p).refs>0) and not(vo_is_funcret in tlocalvarsym(p).varoptions) and not(is_class(tlocalvarsym(p).vartype.def)) and tlocalvarsym(p).vartype.def.needs_inittable then include(current_procinfo.flags,pi_needs_implicit_finally); end; function block(islibrary : boolean) : tnode; begin { parse const,types and vars } read_declarations(islibrary); { do we have an assembler block without the po_assembler? we should allow this for Delphi compatibility (PFV) } if (token=_ASM) and (m_delphi in aktmodeswitches) then include(current_procinfo.procdef.procoptions,po_assembler); { Handle assembler block different } if (po_assembler in current_procinfo.procdef.procoptions) then begin block:=assembler_block; exit; end; {Unit initialization?.} if ( assigned(current_procinfo.procdef.localst) and (current_procinfo.procdef.localst.symtablelevel=main_program_level) and (current_module.is_unit) ) or islibrary then begin if (token=_END) then begin consume(_END); { We need at least a node, else the entry/exit code is not generated and thus no PASCALMAIN symbol which we need (PFV) } if islibrary then block:=cnothingnode.create else block:=nil; end else begin if token=_INITIALIZATION then begin { The library init code is already called and does not need to be in the initfinal table (PFV) } if not islibrary then current_module.flags:=current_module.flags or uf_init; block:=statement_block(_INITIALIZATION); end else if (token=_FINALIZATION) then begin if (current_module.flags and uf_finalize)<>0 then block:=statement_block(_FINALIZATION) else begin { can we allow no INITIALIZATION for DLL ?? I think it should work PM } block:=nil; exit; end; end else begin { The library init code is already called and does not need to be in the initfinal table (PFV) } if not islibrary then current_module.flags:=current_module.flags or uf_init; block:=statement_block(_BEGIN); end; end; end else begin block:=statement_block(_BEGIN); if symtablestack.symtabletype=localsymtable then symtablestack.foreach_static(@initializevars,block); end; end; {**************************************************************************** PROCEDURE/FUNCTION COMPILING ****************************************************************************} procedure printnode_reset; begin assign(printnodefile,treelogfilename); {$I-} rewrite(printnodefile); {$I+} if ioresult<>0 then begin Comment(V_Error,'Error creating '+treelogfilename); exit; end; close(printnodefile); end; function generate_bodyentry_block:tnode; var srsym : tsym; para : tcallparanode; newstatement : tstatementnode; htype : ttype; begin result:=internalstatements(newstatement); if assigned(current_procinfo.procdef._class) then begin { a constructor needs a help procedure } if (current_procinfo.procdef.proctypeoption=potype_constructor) then begin if is_class(current_procinfo.procdef._class) then begin include(current_procinfo.flags,pi_needs_implicit_finally); srsym:=search_class_member(current_procinfo.procdef._class,'NEWINSTANCE'); if assigned(srsym) and (srsym.typ=procsym) then begin { if vmt<>0 then newinstance } addstatement(newstatement,cifnode.create( caddnode.create(unequaln, load_vmt_pointer_node, cnilnode.create), cassignmentnode.create( ctypeconvnode.create_internal( load_self_pointer_node, voidpointertype), ccallnode.create(nil,tprocsym(srsym),srsym.owner,load_vmt_pointer_node,[])), nil)); end else internalerror(200305108); end else if is_object(current_procinfo.procdef._class) then begin htype.setdef(current_procinfo.procdef._class); htype.setdef(tpointerdef.create(htype)); { parameter 3 : vmt_offset } { parameter 2 : address of pointer to vmt, this is required to allow setting the vmt to -1 to indicate that memory was allocated } { parameter 1 : self pointer } para:=ccallparanode.create( cordconstnode.create(current_procinfo.procdef._class.vmt_offset,s32inttype,false), ccallparanode.create( ctypeconvnode.create_internal( load_vmt_pointer_node, voidpointertype), ccallparanode.create( ctypeconvnode.create_internal( load_self_pointer_node, voidpointertype), nil))); addstatement(newstatement,cassignmentnode.create( ctypeconvnode.create_internal( load_self_pointer_node, voidpointertype), ccallnode.createintern('fpc_help_constructor',para))); end else internalerror(200305103); { if self=nil then exit calling fail instead of exit is useless because there is nothing to dispose (PFV) } addstatement(newstatement,cifnode.create( caddnode.create(equaln, load_self_pointer_node, cnilnode.create), cexitnode.create(nil), nil)); end; { maybe call BeforeDestruction for classes } if (current_procinfo.procdef.proctypeoption=potype_destructor) and is_class(current_procinfo.procdef._class) then begin srsym:=search_class_member(current_procinfo.procdef._class,'BEFOREDESTRUCTION'); if assigned(srsym) and (srsym.typ=procsym) then begin { if vmt<>0 then beforedestruction } addstatement(newstatement,cifnode.create( caddnode.create(unequaln, load_vmt_pointer_node, cnilnode.create), ccallnode.create(nil,tprocsym(srsym),srsym.owner,load_self_node,[]), nil)); end else internalerror(200305104); end; end; end; function generate_bodyexit_block:tnode; var srsym : tsym; para : tcallparanode; newstatement : tstatementnode; begin result:=internalstatements(newstatement); if assigned(current_procinfo.procdef._class) then begin { maybe call AfterConstruction for classes } if (current_procinfo.procdef.proctypeoption=potype_constructor) and is_class(current_procinfo.procdef._class) then begin srsym:=search_class_member(current_procinfo.procdef._class,'AFTERCONSTRUCTION'); if assigned(srsym) and (srsym.typ=procsym) then begin { Self can be nil when fail is called } { if self<>nil and vmt<>nil then afterconstruction } addstatement(newstatement,cifnode.create( caddnode.create(andn, caddnode.create(unequaln, load_self_pointer_node, cnilnode.create), caddnode.create(unequaln, load_vmt_pointer_node, cnilnode.create)), ccallnode.create(nil,tprocsym(srsym),srsym.owner,load_self_node,[]), nil)); end else internalerror(200305106); end; { a destructor needs a help procedure } if (current_procinfo.procdef.proctypeoption=potype_destructor) then begin if is_class(current_procinfo.procdef._class) then begin srsym:=search_class_member(current_procinfo.procdef._class,'FREEINSTANCE'); if assigned(srsym) and (srsym.typ=procsym) then begin { if self<>0 and vmt=1 then freeinstance } addstatement(newstatement,cifnode.create( caddnode.create(andn, caddnode.create(unequaln, load_self_pointer_node, cnilnode.create), caddnode.create(equaln, ctypeconvnode.create( load_vmt_pointer_node, voidpointertype), cpointerconstnode.create(1,voidpointertype))), ccallnode.create(nil,tprocsym(srsym),srsym.owner,load_self_node,[]), nil)); end else internalerror(200305108); end else if is_object(current_procinfo.procdef._class) then begin { finalize object data } if current_procinfo.procdef._class.needs_inittable then addstatement(newstatement,finalize_data_node(load_self_node)); { parameter 3 : vmt_offset } { parameter 2 : pointer to vmt } { parameter 1 : self pointer } para:=ccallparanode.create( cordconstnode.create(current_procinfo.procdef._class.vmt_offset,s32inttype,false), ccallparanode.create( ctypeconvnode.create_internal( load_vmt_pointer_node, voidpointertype), ccallparanode.create( ctypeconvnode.create_internal( load_self_pointer_node, voidpointertype), nil))); addstatement(newstatement, ccallnode.createintern('fpc_help_destructor',para)); end else internalerror(200305105); end; end; end; function generate_except_block:tnode; var pd : tprocdef; newstatement : tstatementnode; begin generate_except_block:=internalstatements(newstatement); { a constructor needs call destructor (if available) when it is not inherited } if assigned(current_procinfo.procdef._class) and (current_procinfo.procdef.proctypeoption=potype_constructor) then begin pd:=current_procinfo.procdef._class.searchdestructor; if assigned(pd) then begin { if vmt<>0 then call destructor } addstatement(newstatement,cifnode.create( caddnode.create(unequaln, load_vmt_pointer_node, cnilnode.create), ccallnode.create(nil,tprocsym(pd.procsym),pd.procsym.owner,load_self_node,[]), nil)); end; end else begin { no constructor } { must be the return value finalized before reraising the exception? } if (not is_void(current_procinfo.procdef.rettype.def)) and (current_procinfo.procdef.rettype.def.needs_inittable) and (not is_class(current_procinfo.procdef.rettype.def)) then addstatement(newstatement,finalize_data_node(load_result_node)); end; end; {**************************************************************************** TCGProcInfo ****************************************************************************} constructor tcgprocinfo.create(aparent:tprocinfo); begin inherited Create(aparent); nestedprocs:=tlinkedlist.create; end; destructor tcgprocinfo.destroy; begin nestedprocs.free; if assigned(code) then code.free; inherited destroy; end; procedure tcgprocinfo.printproc; begin assign(printnodefile,treelogfilename); {$I-} append(printnodefile); if ioresult<>0 then rewrite(printnodefile); {$I+} if ioresult<>0 then begin Comment(V_Error,'Error creating '+treelogfilename); exit; end; writeln(printnodefile); writeln(printnodefile,'*******************************************************************************'); writeln(printnodefile,procdef.fullprocname(false)); writeln(printnodefile,'*******************************************************************************'); printnode(printnodefile,code); close(printnodefile); end; procedure tcgprocinfo.add_entry_exit_code; var finalcode, bodyentrycode, bodyexitcode, exceptcode : tnode; newblock : tblocknode; codestatement, newstatement : tstatementnode; oldfilepos : tfileposinfo; begin oldfilepos:=aktfilepos; { Generate code/locations used at start of proc } aktfilepos:=entrypos; entry_asmnode:=casmnode.create_get_position; loadpara_asmnode:=casmnode.create_get_position; stackcheck_asmnode:=casmnode.create_get_position; init_asmnode:=casmnode.create_get_position; bodyentrycode:=generate_bodyentry_block; { Generate code/locations used at end of proc } aktfilepos:=exitpos; exitlabel_asmnode:=casmnode.create_get_position; final_asmnode:=casmnode.create_get_position; bodyexitcode:=generate_bodyexit_block; { Generate procedure by combining init+body+final, depending on the implicit finally we need to add an try...finally...end wrapper } newblock:=internalstatements(newstatement); if (cs_implicit_exceptions in aktmoduleswitches) and (pi_needs_implicit_finally in flags) and { but it's useless in init/final code of units } not(procdef.proctypeoption in [potype_unitfinalize,potype_unitinit]) then begin { Generate special exception block only needed when implicit finaly is used } aktfilepos:=exitpos; exceptcode:=generate_except_block; { Generate code that will be in the try...finally } finalcode:=internalstatements(codestatement); addstatement(codestatement,bodyexitcode); addstatement(codestatement,final_asmnode); { Initialize before try...finally...end frame } addstatement(newstatement,loadpara_asmnode); addstatement(newstatement,stackcheck_asmnode); addstatement(newstatement,entry_asmnode); addstatement(newstatement,init_asmnode); addstatement(newstatement,bodyentrycode); aktfilepos:=entrypos; addstatement(newstatement,ctryfinallynode.create_implicit( code, finalcode, exceptcode)); addstatement(newstatement,exitlabel_asmnode); { set flag the implicit finally has been generated } include(flags,pi_has_implicit_finally); end else begin addstatement(newstatement,loadpara_asmnode); addstatement(newstatement,stackcheck_asmnode); addstatement(newstatement,entry_asmnode); addstatement(newstatement,init_asmnode); addstatement(newstatement,bodyentrycode); addstatement(newstatement,code); addstatement(newstatement,exitlabel_asmnode); addstatement(newstatement,bodyexitcode); addstatement(newstatement,final_asmnode); end; do_firstpass(newblock); code:=newblock; aktfilepos:=oldfilepos; end; procedure clearrefs(p : tnamedindexitem;arg:pointer); begin if (tsym(p).typ in [localvarsym,paravarsym,globalvarsym]) then if tabstractvarsym(p).refs>1 then tabstractvarsym(p).refs:=1; end; procedure tcgprocinfo.generate_code; var oldprocinfo : tprocinfo; oldaktmaxfpuregisters : longint; oldfilepos : tfileposinfo; templist : Taasmoutput; headertai : tai; begin { the initialization procedure can be empty, then we don't need to generate anything. When it was an empty procedure there would be at least a blocknode } if not assigned(code) then exit; { We need valid code } if Errorcount<>0 then exit; { The RA and Tempgen shall not be available yet } if assigned(tg) then internalerror(200309201); oldprocinfo:=current_procinfo; oldfilepos:=aktfilepos; oldaktmaxfpuregisters:=aktmaxfpuregisters; current_procinfo:=self; aktfilepos:=entrypos; { get new labels } aktbreaklabel:=nil; aktcontinuelabel:=nil; templist:=Taasmoutput.create; { add parast/localst to symtablestack } add_to_symtablestack; { when size optimization only count occurrence } if cs_littlesize in aktglobalswitches then cg.t_times:=1 else { reference for repetition is 100 } cg.t_times:=100; { clear register count } symtablestack.foreach_static(@clearrefs,nil); symtablestack.next.foreach_static(@clearrefs,nil); { there's always a call to FPC_INITIALIZEUNITS/FPC_DO_EXIT in the main program } if (procdef.localst.symtablelevel=main_program_level) and (not current_module.is_unit) then include(flags,pi_do_call); { set implicit_finally flag when there are locals/paras to be finalized } current_procinfo.procdef.parast.foreach_static(@check_finalize_paras,nil); current_procinfo.procdef.localst.foreach_static(@check_finalize_locals,nil); { firstpass everything } flowcontrol:=[]; do_firstpass(code); if code.registersfpu>0 then include(current_procinfo.flags,pi_uses_fpu); { add implicit entry and exit code } add_entry_exit_code; { only do secondpass if there are no errors } if ErrorCount=0 then begin { set the start offset to the start of the temp area in the stack } tg:=ttgobj.create; { Create register allocator } cg.init_register_allocators; set_first_temp_offset; generate_parameter_info; { Allocate space in temp/registers for parast and localst } aktfilepos:=entrypos; gen_alloc_symtable(aktproccode,procdef.parast); gen_alloc_symtable(aktproccode,procdef.localst); { Store temp offset for information about 'real' temps } tempstart:=tg.lasttemp; { Generate code to load register parameters in temps and insert local copies for values parameters. This must be done before the code for the body is generated because the localloc is updated. Note: The generated code will be inserted after the code generation of the body is finished, because only then the position is known } {$ifdef oldregvars} assign_regvars(code); {$endif oldreg} aktfilepos:=entrypos; gen_load_para_value(templist); { caller paraloc info is also necessary in the stackframe_entry code of the ppc (and possibly other processors) } if not procdef.has_paraloc_info then begin procdef.requiredargarea:=paramanager.create_paraloc_info(procdef,callerside); procdef.has_paraloc_info:=true; end; { generate code for the node tree } do_secondpass(code); aktproccode.concatlist(exprasmlist); {$ifdef i386} procdef.fpu_used:=code.registersfpu; {$endif i386} { The position of the loadpara_asmnode is now known } aktproccode.insertlistafter(loadpara_asmnode.currenttai,templist); { first generate entry and initialize code with the correct position and switches } aktfilepos:=entrypos; aktlocalswitches:=entryswitches; gen_entry_code(templist); aktproccode.insertlistafter(entry_asmnode.currenttai,templist); gen_initialize_code(templist); aktproccode.insertlistafter(init_asmnode.currenttai,templist); { now generate finalize and exit code with the correct position and switches } aktfilepos:=exitpos; aktlocalswitches:=exitswitches; gen_finalize_code(templist); { the finalcode must be concated if there was no position available, using insertlistafter will result in an insert at the start when currentai=nil } if assigned(final_asmnode.currenttai) then aktproccode.insertlistafter(final_asmnode.currenttai,templist) else aktproccode.concatlist(templist); { insert exit label at the correct position } cg.a_label(templist,aktexitlabel); if assigned(exitlabel_asmnode.currenttai) then aktproccode.insertlistafter(exitlabel_asmnode.currenttai,templist) else aktproccode.concatlist(templist); { exit code } gen_exit_code(templist); aktproccode.concatlist(templist); {$ifdef OLDREGVARS} { note: this must be done only after as much code as possible has } { been generated. The result is that when you ungetregister() a } { regvar, it will actually free the regvar (and alse free the } { the regvars at the same time). Doing this too early will } { confuse the register allocator, as the regvars will still be } { used. It should be done before loading the result regs (so } { they don't conflict with the regvars) and before } { gen_entry_code (that one has to be able to allocate the } { regvars again) (JM) } free_regvars(aktproccode); {$endif OLDREGVARS} { add code that will load the return value, this is not done for assembler routines when they didn't reference the result variable } gen_load_return_value(templist); aktproccode.concatlist(templist); { generate symbol and save end of header position } aktfilepos:=entrypos; gen_proc_symbol(templist); headertai:=tai(templist.last); { insert symbol } aktproccode.insertlist(templist); { Free space in temp/registers for parast and localst, must be done after gen_entry_code } aktfilepos:=exitpos; gen_free_symtable(aktproccode,procdef.localst); gen_free_symtable(aktproccode,procdef.parast); { The procedure body is finished, we can now allocate the registers } cg.do_register_allocation(aktproccode,headertai); { Add save and restore of used registers } aktfilepos:=entrypos; gen_save_used_regs(templist); aktproccode.insertlistafter(headertai,templist); aktfilepos:=exitpos; gen_restore_used_regs(aktproccode); { Add stack checking code } if (cs_check_stack in entryswitches) and not(po_assembler in procdef.procoptions) and (current_procinfo.procdef.proctypeoption<>potype_proginit) then begin aktfilepos:=entrypos; gen_stack_check_code(templist); aktproccode.insertlistafter(stackcheck_asmnode.currenttai,templist) end; { Add entry code (stack allocation) after header } aktfilepos:=entrypos; gen_proc_entry_code(templist); aktproccode.insertlistafter(headertai,templist); { Add exit code at the end } aktfilepos:=exitpos; gen_proc_exit_code(templist); aktproccode.concatlist(templist); { check if the implicit finally has been generated. The flag should already be set in pass1 } if (cs_implicit_exceptions in aktmoduleswitches) and not(procdef.proctypeoption in [potype_unitfinalize,potype_unitinit]) and (pi_needs_implicit_finally in flags) and not(pi_has_implicit_finally in flags) then internalerror(200405231); {$ifndef NoOpt} if not(cs_no_regalloc in aktglobalswitches) then begin if (cs_optimize in aktglobalswitches) and { do not optimize pure assembler procedures } not(pi_is_assembler in flags) then optimize(aktproccode); end; {$endif NoOpt} { Add end symbol and debug info } aktfilepos:=exitpos; gen_proc_symbol_end(templist); aktproccode.concatlist(templist); {$ifdef ARM} insertpcrelativedata(aktproccode,aktlocaldata); {$endif ARM} { save local data (casetable) also in the same file } if assigned(aktlocaldata) and (not aktlocaldata.empty) then begin { because of the limited constant size of the arm, all data access is done pc relative } if target_info.cpu=cpu_arm then aktproccode.concatlist(aktlocaldata) else begin new_section(aktproccode,sec_data,lower(procdef.mangledname),0); aktproccode.concatlist(aktlocaldata); end; end; { add the procedure to the codesegment } maybe_new_object_file(codesegment); new_section(codesegment,sec_code,lower(procdef.mangledname),aktalignment.procalign); codesegment.concatlist(aktproccode); { only now we can remove the temps } tg.resettempgen; { stop tempgen and ra } tg.free; cg.done_register_allocators; tg:=nil; end; { restore symtablestack } remove_from_symtablestack; { restore } templist.free; aktmaxfpuregisters:=oldaktmaxfpuregisters; aktfilepos:=oldfilepos; current_procinfo:=oldprocinfo; end; procedure tcgprocinfo.add_to_symtablestack; var _class,hp : tobjectdef; begin { insert symtables for the class, but only if it is no nested function } if assigned(procdef._class) and not(assigned(parent) and assigned(parent.procdef) and assigned(parent.procdef._class)) then begin { insert them in the reverse order } hp:=nil; repeat _class:=procdef._class; while _class.childof<>hp do _class:=_class.childof; hp:=_class; _class.symtable.next:=symtablestack; symtablestack:=_class.symtable; until hp=procdef._class; end; { insert parasymtable in symtablestack when parsing a function } if procdef.parast.symtablelevel>=normal_function_level then begin procdef.parast.next:=symtablestack; symtablestack:=procdef.parast; end; procdef.localst.next:=symtablestack; symtablestack:=procdef.localst; end; procedure tcgprocinfo.remove_from_symtablestack; begin { remove localst/parast } if procdef.parast.symtablelevel>=normal_function_level then symtablestack:=symtablestack.next.next else symtablestack:=symtablestack.next; { remove class member symbol tables } while symtablestack.symtabletype=objectsymtable do symtablestack:=symtablestack.next; end; procedure tcgprocinfo.resetprocdef; begin { remove code tree, if not inline procedure } if assigned(code) then begin { the inline procedure has already got a copy of the tree stored in procdef.inlininginfo } code.free; code:=nil; end; end; function checknodeinlining(procdef: tprocdef): boolean; var i : integer; currpara : tparavarsym; begin result := false; if (po_assembler in procdef.procoptions) then exit; for i:=0 to procdef.paras.count-1 do begin currpara:=tparavarsym(procdef.paras[i]); { we can't handle formaldefs and special arrays (the latter may need a } { re-basing of the index, i.e. if you pass an array[1..10] as open array, } { you have to add 1 to all index operations if you directly inline it } if ((currpara.varspez in [vs_out,vs_var]) and (currpara.vartype.def.deftype=formaldef)) or is_special_array(currpara.vartype.def) then exit; end; result:=true; end; function checklocalinlining(var n: tnode; arg: pointer): foreachnoderesult; begin result:=fen_false; case n.nodetype of loadn : if tloadnode(n).symtableentry.owner.symtabletype=staticsymtable then result:=fen_norecurse_true; calln : if tcallnode(n).procdefinition.owner.symtabletype=staticsymtable then result:=fen_norecurse_true; end; end; procedure tcgprocinfo.parse_body; var oldprocinfo : tprocinfo; oldblock_type : tblock_type; begin oldprocinfo:=current_procinfo; oldblock_type:=block_type; { reset break and continue labels } block_type:=bt_body; current_procinfo:=self; { calculate the lexical level } if procdef.parast.symtablelevel>maxnesting then Message(parser_e_too_much_lexlevel); { static is also important for local procedures !! } if (po_staticmethod in procdef.procoptions) then allow_only_static:=true else if (procdef.parast.symtablelevel=normal_function_level) then allow_only_static:=false; {$ifdef state_tracking} { aktstate:=Tstate_storage.create;} {$endif state_tracking} { create a local symbol table for this routine } if not assigned(procdef.localst) then procdef.insert_localst; { add parast/localst to symtablestack } add_to_symtablestack; { constant symbols are inserted in this symboltable } constsymtable:=symtablestack; { save entry info } entrypos:=aktfilepos; entryswitches:=aktlocalswitches; { parse the code ... } code:=block(current_module.islibrary); { save exit info } exitswitches:=aktlocalswitches; exitpos:=last_endtoken_filepos; { the procedure is now defined } procdef.forwarddef:=false; if assigned(code) then begin { get a better entry point } entrypos:=code.fileinfo; { Finish type checking pass } do_resulttypepass(code); end; { Check for unused labels, forwards, symbols for procedures. Static symtable is checked in pmodules. The check must be done after the resulttypepass } if (Errorcount=0) and (tstoredsymtable(procdef.localst).symtabletype<>staticsymtable) then begin { check if forwards are resolved } tstoredsymtable(procdef.localst).check_forwards; { check if all labels are used } tstoredsymtable(procdef.localst).checklabels; { remove cross unit overloads } tstoredsymtable(procdef.localst).unchain_overloaded; { check for unused symbols, but only if there is no asm block } if not(pi_has_assembler_block in flags) then begin tstoredsymtable(procdef.localst).allsymbolsused; tstoredsymtable(procdef.parast).allsymbolsused; end; end; if (procdef.proccalloption=pocall_inline) then begin { Can we inline this procedure? } if checknodeinlining(procdef) then begin new(procdef.inlininginfo); include(procdef.procoptions,po_has_inlininginfo); procdef.inlininginfo^.code:=code.getcopy; procdef.inlininginfo^.flags:=current_procinfo.flags; { References a local var or proc? } if foreachnodestatic(procdef.inlininginfo^.code,@checklocalinlining,nil) then include(procdef.inlininginfo^.flags,pi_inline_local_only); { The blocknode needs to set an exit label } if procdef.inlininginfo^.code.nodetype=blockn then include(procdef.inlininginfo^.code.flags,nf_block_with_exit); end; end; { Print the node to tree.log } if paraprintnodetree=1 then printproc; { ... remove symbol tables } remove_from_symtablestack; {$ifdef state_tracking} { aktstate.destroy;} {$endif state_tracking} { reset to normal non static function } if (procdef.parast.symtablelevel=normal_function_level) then allow_only_static:=false; current_procinfo:=oldprocinfo; block_type:=oldblock_type; end; {**************************************************************************** PROCEDURE/FUNCTION PARSING ****************************************************************************} procedure check_init_paras(p:tnamedindexitem;arg:pointer); begin if tsym(p).typ<>paravarsym then exit; with tparavarsym(p) do if (not is_class(vartype.def) and vartype.def.needs_inittable and (varspez in [vs_value,vs_out])) then include(current_procinfo.flags,pi_do_call); end; procedure read_proc; { Parses the procedure directives, then parses the procedure body, then generates the code for it } procedure do_generate_code(pi:tcgprocinfo); var hpi : tcgprocinfo; begin { generate code for this procedure } pi.generate_code; { process nested procs } hpi:=tcgprocinfo(pi.nestedprocs.first); while assigned(hpi) do begin do_generate_code(hpi); hpi:=tcgprocinfo(hpi.next); end; pi.resetprocdef; end; var old_current_procinfo : tprocinfo; oldconstsymtable : tsymtable; oldfailtokenmode : tmodeswitch; pdflags : tpdflags; pd : tprocdef; isnestedproc : boolean; s : string; begin { save old state } oldconstsymtable:=constsymtable; old_current_procinfo:=current_procinfo; { reset current_procinfo.procdef to nil to be sure that nothing is writing to an other procdef } current_procinfo:=nil; { parse procedure declaration } if assigned(old_current_procinfo) and assigned(old_current_procinfo.procdef) then pd:=parse_proc_dec(old_current_procinfo.procdef._class) else pd:=parse_proc_dec(nil); { set the default function options } if parse_only then begin pd.forwarddef:=true; { set also the interface flag, for better error message when the implementation doesn't much this header } pd.interfacedef:=true; include(pd.procoptions,po_global); pdflags:=[pd_interface]; end else begin pdflags:=[pd_body]; if (not current_module.in_interface) then include(pdflags,pd_implemen); if (not current_module.is_unit) or maybe_smartlink_symbol then include(pd.procoptions,po_global); pd.forwarddef:=false; end; { parse the directives that may follow } parse_proc_directives(pd,pdflags); { hint directives, these can be separated by semicolons here, that needs to be handled here with a loop (PFV) } while try_consume_hintdirective(pd.symoptions) do Consume(_SEMICOLON); { Set calling convention } handle_calling_convention(pd); { search for forward declarations } if not proc_add_definition(pd) then begin { A method must be forward defined (in the object declaration) } if assigned(pd._class) and (not assigned(old_current_procinfo.procdef._class)) then begin MessagePos1(pd.fileinfo,parser_e_header_dont_match_any_member,pd.fullprocname(false)); tprocsym(pd.procsym).write_parameter_lists(pd); end else begin { Give a better error if there is a forward def in the interface and only a single implementation } if (not pd.forwarddef) and (not pd.interfacedef) and (tprocsym(pd.procsym).procdef_count>1) and tprocsym(pd.procsym).first_procdef.forwarddef and tprocsym(pd.procsym).first_procdef.interfacedef and not(tprocsym(pd.procsym).procdef_count>2) then begin MessagePos1(pd.fileinfo,parser_e_header_dont_match_forward,pd.fullprocname(false)); tprocsym(pd.procsym).write_parameter_lists(pd); end; end; end; { Set mangled name } proc_set_mangledname(pd); { compile procedure when a body is needed } if (pd_body in pdflags) then begin Message1(parser_d_procedure_start,pd.fullprocname(false)); { create a new procedure } current_procinfo:=cprocinfo.create(old_current_procinfo); current_module.procinfo:=current_procinfo; current_procinfo.procdef:=pd; isnestedproc:=(current_procinfo.procdef.parast.symtablelevel>normal_function_level); { Insert mangledname } pd.aliasnames.insert(pd.mangledname); { Handle Export of this procedure } if (po_exports in pd.procoptions) and (target_info.system in [system_i386_os2,system_i386_emx]) then begin pd.aliasnames.insert(pd.procsym.realname); if cs_link_deffile in aktglobalswitches then deffile.AddExport(pd.mangledname); end; { Insert result variables in the localst } insert_funcret_local(pd); { check if there are para's which require initing -> set } { pi_do_call (if not yet set) } if not(pi_do_call in current_procinfo.flags) then pd.parast.foreach_static(@check_init_paras,nil); { set _FAIL as keyword if constructor } if (pd.proctypeoption=potype_constructor) then begin oldfailtokenmode:=tokeninfo^[_FAIL].keyword; tokeninfo^[_FAIL].keyword:=m_all; end; tcgprocinfo(current_procinfo).parse_body; { When it's a nested procedure then defer the code generation, when back at normal function level then generate the code for all defered nested procedures and the current procedure } if isnestedproc then tcgprocinfo(current_procinfo.parent).nestedprocs.insert(current_procinfo) else begin { We can't support inlining for procedures that have nested procedures because the nested procedures use a fixed offset for accessing locals in the parent procedure (PFV) } if (current_procinfo.procdef.proccalloption=pocall_inline) and (tcgprocinfo(current_procinfo).nestedprocs.count>0) then begin Message1(parser_w_not_supported_for_inline,'nested procedures'); Message(parser_w_inlining_disabled); current_procinfo.procdef.proccalloption:=pocall_default; end; do_generate_code(tcgprocinfo(current_procinfo)); end; { reset _FAIL as _SELF normal } if (pd.proctypeoption=potype_constructor) then tokeninfo^[_FAIL].keyword:=oldfailtokenmode; { release procinfo } if tprocinfo(current_module.procinfo)<>current_procinfo then internalerror(200304274); current_module.procinfo:=current_procinfo.parent; if not isnestedproc then current_procinfo.free; consume(_SEMICOLON); end else begin { Handle imports } if (po_external in pd.procoptions) then begin { External declared in implementation, and there was already a forward (or interface) declaration then we need to generate a stub that calls the external routine } if (not pd.forwarddef) and (pd.hasforward) and not( assigned(pd.import_dll) and (target_info.system in [system_i386_win32,system_i386_wdosx, system_i386_emx,system_i386_os2]) ) then begin s:=proc_get_importname(pd); if s<>'' then gen_external_stub(codesegment,pd,s); end; { Import DLL specified? } if assigned(pd.import_dll) then begin { create importlib if not already done } if not(current_module.uses_imports) then begin current_module.uses_imports:=true; importlib.preparelib(current_module.realmodulename^); end; if assigned(pd.import_name) then importlib.importprocedure(pd,pd.import_dll^,pd.import_nr,pd.import_name^) else importlib.importprocedure(pd,pd.import_dll^,pd.import_nr,''); end else begin { add import name to external list for DLL scanning } if target_info.DllScanSupported then current_module.externals.insert(tExternalsItem.create(proc_get_importname(pd))); end; end; end; { Restore old state } constsymtable:=oldconstsymtable; current_procinfo:=old_current_procinfo; end; {**************************************************************************** DECLARATION PARSING ****************************************************************************} { search in symtablestack for not complete classes } procedure check_forward_class(p : tnamedindexitem;arg:pointer); begin if (tsym(p).typ=typesym) and (ttypesym(p).restype.def.deftype=objectdef) and (oo_is_forward in tobjectdef(ttypesym(p).restype.def).objectoptions) then MessagePos1(tsym(p).fileinfo,sym_e_forward_type_not_resolved,tsym(p).realname); end; procedure read_declarations(islibrary : boolean); begin repeat if not assigned(current_procinfo) then internalerror(200304251); case token of _LABEL: label_dec; _CONST: const_dec; _TYPE: type_dec; _VAR: var_dec; _THREADVAR: threadvar_dec; _CONSTRUCTOR, _DESTRUCTOR, _FUNCTION, _PROCEDURE, _OPERATOR, _CLASS: read_proc; _EXPORTS: begin if not(assigned(current_procinfo.procdef.localst)) or (current_procinfo.procdef.localst.symtablelevel>main_program_level) or (current_module.is_unit) then begin Message(parser_e_syntax_error); consume_all_until(_SEMICOLON); end else if islibrary or (target_info.system in [system_i386_WIN32,system_i386_wdosx,system_i386_Netware,system_i386_netwlibc]) then read_exports else begin Message(parser_w_unsupported_feature); consume(_BEGIN); end; end else begin case idtoken of _RESOURCESTRING : resourcestring_dec; _PROPERTY: begin if (m_fpc in aktmodeswitches) then property_dec else break; end; else break; end; end; end; until false; { check for incomplete class definitions, this is only required for fpc modes } if (m_fpc in aktmodeswitches) then symtablestack.foreach_static(@check_forward_class,nil); end; procedure read_interface_declarations; begin repeat case token of _CONST : const_dec; _TYPE : type_dec; _VAR : var_dec; _THREADVAR : threadvar_dec; _FUNCTION, _PROCEDURE, _OPERATOR : read_proc; else begin case idtoken of _RESOURCESTRING : resourcestring_dec; _PROPERTY: begin if (m_fpc in aktmodeswitches) then property_dec else break; end; else break; end; end; end; until false; { check for incomplete class definitions, this is only required for fpc modes } if (m_fpc in aktmodeswitches) then symtablestack.foreach_static(@check_forward_class,nil); end; end. { $Log$ Revision 1.225 2004-12-15 21:08:15 peter * disable inlining across units when the inline procedure references a variable or procedure in the static symtable Revision 1.224 2004/12/15 17:01:28 peter * fixed crash with -vp Revision 1.223 2004/12/15 16:00:16 peter * external is again allowed in implementation Revision 1.222 2004/12/05 12:28:11 peter * procvar handling for tp procvar mode fixed * proc to procvar moved from addrnode to typeconvnode * inlininginfo is now allocated only for inline routines that can be inlined, introduced a new flag po_has_inlining_info Revision 1.221 2004/12/02 19:26:15 peter * disable pass2inline Revision 1.220 2004/11/29 18:50:15 peter * os2 fixes for import * asmsymtype support for intel reader Revision 1.219 2004/11/21 17:17:03 florian * changed funcret location back to tlocation Revision 1.218 2004/11/19 08:17:02 michael * Split po_public into po_public and po_global (Peter) Revision 1.217 2004/11/17 22:21:35 peter mangledname setting moved to place after the complete proc declaration is read import generation moved to place where body is also parsed (still gives problems with win32) Revision 1.216 2004/11/16 20:32:41 peter * fixes for win32 mangledname Revision 1.215 2004/11/15 23:35:31 peter * tparaitem removed, use tparavarsym instead * parameter order is now calculated from paranr value in tparavarsym Revision 1.214 2004/11/08 22:09:59 peter * tvarsym splitted Revision 1.213 2004/11/02 12:55:17 peter * nf_internal flag for internal inserted typeconvs. This will supress the generation of warning/hints Revision 1.212 2004/10/31 18:54:25 peter * $fpctarget expands to - * allow * in middle of the path to support ../*/units/$fpctarget Revision 1.211 2004/10/30 15:21:37 florian * fixed generic optimizer * enabled generic optimizer for sparc Revision 1.210 2004/10/24 20:01:08 peter * remove saveregister calling convention Revision 1.209 2004/10/15 09:14:17 mazen - remove $IFDEF DELPHI and related code - remove $IFDEF FPCPROCVAR and related code Revision 1.208 2004/10/10 20:22:53 peter * symtable allocation rewritten * loading of parameters to local temps/regs cleanup * regvar support for parameters * regvar support for staticsymtable (main body) Revision 1.207 2004/09/26 17:45:30 peter * simple regvar support, not yet finished Revision 1.206 2004/09/21 17:25:12 peter * paraloc branch merged Revision 1.205 2004/09/13 20:34:28 peter * keep localst in memory, it is also needed for finalizing typedconst Revision 1.204 2004/09/04 21:18:47 armin * target netwlibc added (libc is preferred for newer netware versions) Revision 1.203.4.1 2004/09/17 17:19:26 peter * fixed 64 bit unaryminus for sparc * fixed 64 bit inlining * signness of not operation Revision 1.203 2004/08/14 14:50:42 florian * fixed several sparc alignment issues + Jonas' inline node patch; non functional yet Revision 1.202 2004/07/16 21:11:31 jonas - disable node-based inlining of routines with special array parameters for now (de indexes of open arrays have to be changed, because on the caller-side these routines are not necessarily 0-based) Revision 1.201 2004/07/15 19:55:40 jonas + (incomplete) node_complexity function to assess the complexity of a tree + support for inlining value and const parameters at the node level (all procedures without local variables and without formal parameters can now be inlined at the node level) Revision 1.200 2004/07/12 09:14:04 jonas * inline procedures at the node tree level, but only under some very limited circumstances for now (only procedures, and only if they have no or only vs_out/vs_var parameters). * fixed ppudump for inline procedures * fixed ppudump for ppc Revision 1.199 2004/07/10 20:24:34 peter * put every proc in a new object file Revision 1.198 2004/07/09 22:17:32 peter * revert has_localst patch * replace aktstaticsymtable/aktglobalsymtable with current_module Revision 1.197 2004/07/06 19:52:04 peter * fix storing of localst in ppu Revision 1.196 2004/06/20 08:55:30 florian * logs truncated Revision 1.195 2004/06/16 20:07:09 florian * dwarf branch merged Revision 1.194 2004/05/28 21:14:13 peter * first load para's to temps before calling entry code (profile Revision 1.193 2004/05/24 17:31:12 peter * also check local typed const Revision 1.192 2004/05/23 18:28:41 peter * methodpointer is loaded into a temp when it was a calln Revision 1.191 2004/05/23 15:06:21 peter * implicit_finally flag must be set in pass1 * add check whether the implicit frame is generated when expected }