123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073 |
- {
- 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,optdfa;
- type
- tcgprocinfo = class(tprocinfo)
- private
- procedure maybe_add_constructor_wrapper(var tocode: tnode; withexceptblock: boolean);
- 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;
- dfabuilder : TDFABuilder;
- destructor destroy;override;
- procedure printproc(pass:string);
- procedure generate_code;
- procedure resetprocdef;
- procedure add_to_symtablestack;
- procedure remove_from_symtablestack;
- procedure parse_body;
- function has_assembler_child : boolean;
- 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;
- procedure generate_specialization_procs;
- implementation
- uses
- sysutils,
- { common }
- cutils,
- { global }
- globtype,tokens,verbose,comphook,constexp,
- systems,
- { aasm }
- cpuinfo,cpubase,aasmbase,aasmtai,aasmdata,
- { 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,cgbase,cgobj,cgcpu,dbgbase,
- ncgutil,regvars,
- optbase,
- opttail,
- optcse,optloop,
- optutils
- {$if defined(arm) or defined(powerpc) or defined(powerpc64)}
- ,aasmcpu
- {$endif arm}
- {$ifndef NOOPT}
- {$ifdef i386}
- ,aopt386
- {$else i386}
- ,aopt
- {$endif i386}
- {$endif}
- ;
- {****************************************************************************
- PROCEDURE/FUNCTION BODY PARSING
- ****************************************************************************}
- procedure initializevars(p:TObject;arg:pointer);
- var
- b : tblocknode;
- begin
- if not (tsym(p).typ in [localvarsym,staticvarsym]) 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:TObject;arg:pointer);
- begin
- if (tsym(p).typ=paravarsym) and
- (tparavarsym(p).varspez=vs_value) and
- is_managed_type(tparavarsym(p).vardef) then
- include(current_procinfo.flags,pi_needs_implicit_finally);
- end;
- procedure check_finalize_locals(p:TObject;arg:pointer);
- begin
- { include the result: it needs to be finalized in case an exception }
- { occurs }
- if (tsym(p).typ=localvarsym) and
- (tlocalvarsym(p).refs>0) and
- is_managed_type(tlocalvarsym(p).vardef) then
- include(current_procinfo.flags,pi_needs_implicit_finally);
- end;
- function block(islibrary : boolean) : tnode;
- var
- oldfilepos: tfileposinfo;
- 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 current_settings.modeswitches) 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) }
- block:=statement_block(_INITIALIZATION);
- { optimize empty initialization block away }
- if (block.nodetype=blockn) and (tblocknode(block).left=nil) then
- FreeAndNil(block)
- else
- if not islibrary then
- current_module.flags:=current_module.flags or uf_init;
- end
- else if token=_FINALIZATION then
- begin
- { when a unit has only a finalization section, we can come to this
- point when we try to read the nonh existing initalization section
- so we've to check if we are really try to parse the finalization }
- if current_procinfo.procdef.proctypeoption=potype_unitfinalize then
- begin
- block:=statement_block(_FINALIZATION);
- { optimize empty finalization block away }
- if (block.nodetype=blockn) and (tblocknode(block).left=nil) then
- FreeAndNil(block)
- else
- current_module.flags:=current_module.flags or uf_finalize;
- end
- else
- block:=nil;
- 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 current_procinfo.procdef.localst.symtabletype=localsymtable then
- begin
- { initialization of local variables with their initial
- values: part of function entry }
- oldfilepos:=current_filepos;
- current_filepos:=current_procinfo.entrypos;
- current_procinfo.procdef.localst.SymList.ForEachCall(@initializevars,block);
- current_filepos:=oldfilepos;
- end;
- 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;
- procedure add_label_init(p:TObject;arg:pointer);
- begin
- if tstoredsym(p).typ=labelsym then
- begin
- addstatement(tstatementnode(arg^),
- cifnode.create(caddnode.create(equaln,
- ccallnode.createintern('fpc_setjmp',
- ccallparanode.create(cloadnode.create(tlabelsym(p).jumpbuf,tlabelsym(p).jumpbuf.owner),nil)),
- cordconstnode.create(1,sinttype,true))
- ,cgotonode.create(tlabelsym(p)),nil)
- );
- end;
- end;
- function generate_bodyentry_block:tnode;
- var
- srsym : tsym;
- para : tcallparanode;
- newstatement : tstatementnode;
- begin
- result:=internalstatements(newstatement);
- if assigned(current_structdef) then
- begin
- { a constructor needs a help procedure }
- if (current_procinfo.procdef.proctypeoption=potype_constructor) then
- begin
- if is_class(current_structdef) then
- begin
- include(current_procinfo.flags,pi_needs_implicit_finally);
- srsym:=search_struct_member(current_structdef,'NEWINSTANCE');
- if assigned(srsym) and
- (srsym.typ=procsym) then
- begin
- { if vmt>1 then newinstance }
- addstatement(newstatement,cifnode.create(
- caddnode.create(gtn,
- ctypeconvnode.create_internal(
- load_vmt_pointer_node,
- voidpointertype),
- cpointerconstnode.create(1,voidpointertype)),
- 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_structdef) then
- begin
- { 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(tobjectdef(current_structdef).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
- if not is_record(current_structdef) then
- internalerror(200305103);
- { if self=nil then exit
- calling fail instead of exit is useless because
- there is nothing to dispose (PFV) }
- if is_class_or_object(current_structdef) then
- 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_structdef) then
- begin
- srsym:=search_struct_member(current_structdef,'BEFOREDESTRUCTION');
- if assigned(srsym) and
- (srsym.typ=procsym) then
- begin
- { if vmt>0 then beforedestruction }
- addstatement(newstatement,cifnode.create(
- caddnode.create(gtn,
- ctypeconvnode.create_internal(
- load_vmt_pointer_node,ptrsinttype),
- ctypeconvnode.create_internal(
- cnilnode.create,ptrsinttype)),
- ccallnode.create(nil,tprocsym(srsym),srsym.owner,load_self_node,[]),
- nil));
- end
- else
- internalerror(200305104);
- end;
- end;
- if m_non_local_goto in current_settings.modeswitches then
- tsymtable(current_procinfo.procdef.localst).SymList.ForEachCall(@add_label_init,@newstatement);
- end;
- function generate_bodyexit_block:tnode;
- var
- srsym : tsym;
- para : tcallparanode;
- newstatement : tstatementnode;
- oldlocalswitches: tlocalswitches;
- begin
- result:=internalstatements(newstatement);
- if assigned(current_structdef) then
- begin
- { Don't test self and the vmt here. The reason is that }
- { a constructor already checks whether these are valid }
- { before. Further, in case of TThread the thread may }
- { free the class instance right after AfterConstruction }
- { has been called, so it may no longer be valid (JM) }
- oldlocalswitches:=current_settings.localswitches;
- current_settings.localswitches:=oldlocalswitches-[cs_check_object,cs_check_range];
- { a destructor needs a help procedure }
- if (current_procinfo.procdef.proctypeoption=potype_destructor) then
- begin
- if is_class(current_structdef) then
- begin
- srsym:=search_struct_member(current_structdef,'FREEINSTANCE');
- if assigned(srsym) and
- (srsym.typ=procsym) then
- begin
- { if self<>0 and vmt<>0 then freeinstance }
- addstatement(newstatement,cifnode.create(
- caddnode.create(andn,
- caddnode.create(unequaln,
- load_self_pointer_node,
- cnilnode.create),
- caddnode.create(unequaln,
- ctypeconvnode.create(
- load_vmt_pointer_node,
- voidpointertype),
- cpointerconstnode.create(0,voidpointertype))),
- ccallnode.create(nil,tprocsym(srsym),srsym.owner,load_self_node,[]),
- nil));
- end
- else
- internalerror(200305108);
- end
- else
- if is_object(current_structdef) then
- begin
- { finalize object data, but only if not in inherited call }
- if is_managed_type(current_structdef) then
- begin
- addstatement(newstatement,cifnode.create(
- caddnode.create(unequaln,
- ctypeconvnode.create_internal(load_vmt_pointer_node,voidpointertype),
- cnilnode.create),
- finalize_data_node(load_self_node),
- nil));
- end;
- { parameter 3 : vmt_offset }
- { parameter 2 : pointer to vmt }
- { parameter 1 : self pointer }
- para:=ccallparanode.create(
- cordconstnode.create(tobjectdef(current_structdef).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;
- current_settings.localswitches:=oldlocalswitches;
- end;
- end;
- function generate_except_block:tnode;
- var
- newstatement : tstatementnode;
- { safecall handling }
- exceptobjnode,exceptaddrnode: ttempcreatenode;
- sym,exceptsym: tsym;
- begin
- generate_except_block:=internalstatements(newstatement);
- { a constructor needs call destructor (if available) when it
- is not inherited }
- if not assigned(current_structdef) or
- (current_procinfo.procdef.proctypeoption<>potype_constructor) then
- begin
- { no constructor }
- { must be the return value finalized before reraising the exception? }
- if (not is_void(current_procinfo.procdef.returndef)) and
- is_managed_type(current_procinfo.procdef.returndef) and
- (not paramanager.ret_in_param(current_procinfo.procdef.returndef, current_procinfo.procdef.proccalloption)) and
- (not is_class(current_procinfo.procdef.returndef)) then
- addstatement(newstatement,finalize_data_node(load_result_node));
- {$if defined(x86) or defined(arm)}
- { safecall handling }
- if (tf_safecall_exceptions in target_info.flags) and
- (current_procinfo.procdef.proccalloption=pocall_safecall) then
- begin
- { create a local hidden variable "safe_result" }
- { it will be used in ncgflw unit }
- { to set "real" result value for safecall routine }
- sym:=tlocalvarsym.create('$safe_result',vs_value,hresultdef,[]);
- include(sym.symoptions,sp_internal);
- current_procinfo.procdef.localst.insert(sym);
- { if safecall is used for a class method we need to call }
- { SafecallException virtual method }
- { In other case we return E_UNEXPECTED error value }
- if is_class(current_procinfo.procdef.struct) then
- begin
- { temp variable to store exception address }
- exceptaddrnode:=ctempcreatenode.create(voidpointertype,voidpointertype.size,
- tt_persistent,true);
- addstatement(newstatement,exceptaddrnode);
- addstatement(newstatement,
- cassignmentnode.create(
- ctemprefnode.create(exceptaddrnode),
- ccallnode.createintern('fpc_getexceptionaddr',nil)));
- { temp variable to store popped up exception }
- exceptobjnode:=ctempcreatenode.create(class_tobject,class_tobject.size,
- tt_persistent,true);
- addstatement(newstatement,exceptobjnode);
- addstatement(newstatement,
- cassignmentnode.create(
- ctemprefnode.create(exceptobjnode),
- ccallnode.createintern('fpc_popobjectstack', nil)));
- exceptsym:=search_struct_member(tobjectdef(current_procinfo.procdef.struct),'SAFECALLEXCEPTION');
- addstatement(newstatement,
- cassignmentnode.create(
- cloadnode.create(sym,sym.Owner),
- ccallnode.create(
- ccallparanode.create(ctemprefnode.create(exceptaddrnode),
- ccallparanode.create(ctemprefnode.create(exceptobjnode),nil)),
- tprocsym(exceptsym), tprocsym(exceptsym).owner,load_self_node,[])));
- addstatement(newstatement,ccallnode.createintern('fpc_destroyexception',
- ccallparanode.create(ctemprefnode.create(exceptobjnode),nil)));
- addstatement(newstatement,ctempdeletenode.create(exceptobjnode));
- addstatement(newstatement,ctempdeletenode.create(exceptaddrnode));
- end
- else
- begin
- { pop up and destroy an exception }
- addstatement(newstatement,ccallnode.createintern('fpc_destroyexception',
- ccallparanode.create(ccallnode.createintern('fpc_popobjectstack', nil),nil)));
- addstatement(newstatement,
- cassignmentnode.create(
- cloadnode.create(sym,sym.Owner),
- genintconstnode(HResult($8000FFFF))));
- end;
- end;
- {$endif}
- end;
- end;
- {****************************************************************************
- TCGProcInfo
- ****************************************************************************}
- destructor tcgprocinfo.destroy;
- begin
- if assigned(code) then
- code.free;
- inherited destroy;
- end;
- procedure tcgprocinfo.printproc(pass:string);
- 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, pass);
- writeln(printnodefile,procdef.fullprocname(false));
- writeln(printnodefile,'*******************************************************************************');
- printnode(printnodefile,code);
- close(printnodefile);
- end;
- procedure tcgprocinfo.maybe_add_constructor_wrapper(var tocode: tnode; withexceptblock: boolean);
- var
- oldlocalswitches: tlocalswitches;
- srsym: tsym;
- afterconstructionblock,
- exceptblock,
- newblock: tblocknode;
- newstatement: tstatementnode;
- pd: tprocdef;
- begin
- if assigned(current_structdef) and
- (current_procinfo.procdef.proctypeoption=potype_constructor) then
- begin
- { Don't test self and the vmt here. See generate_bodyexit_block }
- { why (JM) }
- oldlocalswitches:=current_settings.localswitches;
- current_settings.localswitches:=oldlocalswitches-[cs_check_object,cs_check_range];
- { call AfterConstruction for classes }
- if is_class(current_structdef) then
- begin
- srsym:=search_struct_member(current_structdef,'AFTERCONSTRUCTION');
- if assigned(srsym) and
- (srsym.typ=procsym) then
- begin
- current_filepos:=exitpos;
- afterconstructionblock:=internalstatements(newstatement);
- { first execute all constructor code. If no exception
- occurred then we will execute afterconstruction,
- otherwise we won't (the exception will jump over us) }
- addstatement(newstatement,tocode);
- { 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_node,
- cnilnode.create),
- caddnode.create(unequaln,
- load_vmt_pointer_node,
- cnilnode.create)),
- ccallnode.create(nil,tprocsym(srsym),srsym.owner,load_self_node,[]),
- nil));
- tocode:=afterconstructionblock;
- end
- else
- internalerror(200305106);
- end;
- if withexceptblock and (current_structdef.typ=objectdef) then
- begin
- { Generate the implicit "fail" code for a constructor (destroy
- in case an exception happened) }
- pd:=tobjectdef(current_structdef).find_destructor;
- { this will always be the case for classes, since tobject has
- a destructor }
- if assigned(pd) then
- begin
- current_filepos:=exitpos;
- exceptblock:=internalstatements(newstatement);
- { first free the instance if non-nil }
- { if vmt<>0 then call destructor }
- addstatement(newstatement,cifnode.create(
- caddnode.create(unequaln,
- load_vmt_pointer_node,
- cnilnode.create),
- { cnf_create_failed -> don't call BeforeDestruction }
- ccallnode.create(nil,tprocsym(pd.procsym),pd.procsym.owner,load_self_node,[cnf_create_failed]),
- nil));
- { then re-raise the exception }
- addstatement(newstatement,craisenode.create(nil,nil,nil));
- current_filepos:=entrypos;
- newblock:=internalstatements(newstatement);
- { try
- tocode
- except
- exceptblock
- end
- }
- addstatement(newstatement,ctryexceptnode.create(
- tocode,
- nil,
- exceptblock));
- tocode:=newblock;
- end;
- end;
- current_settings.localswitches:=oldlocalswitches;
- end;
- end;
- procedure tcgprocinfo.add_entry_exit_code;
- var
- finalcode,
- bodyentrycode,
- bodyexitcode,
- exceptcode,
- wrappedbody: tnode;
- newblock : tblocknode;
- codestatement,
- newstatement : tstatementnode;
- oldfilepos : tfileposinfo;
- begin
- oldfilepos:=current_filepos;
- { Generate code/locations used at start of proc }
- current_filepos:=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 }
- current_filepos:=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 current_settings.moduleswitches) 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 }
- current_filepos:=exitpos;
- exceptcode:=generate_except_block;
- { Generate code that will be in the try...finally }
- finalcode:=internalstatements(codestatement);
- 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);
- current_filepos:=entrypos;
- wrappedbody:=ctryfinallynode.create_implicit(
- code,
- finalcode,
- exceptcode);
- { afterconstruction must be called after final_asmnode, because it
- has to execute after the temps have been finalised in case of a
- refcounted class (afterconstruction decreases the refcount
- without freeing the instance if the count becomes nil, while
- the finalising of the temps can free the instance) }
- maybe_add_constructor_wrapper(wrappedbody,true);
- addstatement(newstatement,wrappedbody);
- addstatement(newstatement,exitlabel_asmnode);
- addstatement(newstatement,bodyexitcode);
- { set flag the implicit finally has been generated }
- include(flags,pi_has_implicit_finally);
- end
- else
- begin
- maybe_add_constructor_wrapper(code,false);
- 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(tnode(newblock));
- code:=newblock;
- current_filepos:=oldfilepos;
- end;
- procedure clearrefs(p:TObject;arg:pointer);
- begin
- if (tsym(p).typ in [localvarsym,paravarsym,staticvarsym]) then
- if tabstractvarsym(p).refs>1 then
- tabstractvarsym(p).refs:=1;
- end;
- procedure translate_registers(p:TObject;list:pointer);
- begin
- if (tsym(p).typ in [localvarsym,paravarsym,staticvarsym]) and
- (tabstractnormalvarsym(p).localloc.loc in [LOC_REGISTER,LOC_CREGISTER,LOC_MMREGISTER,
- LOC_CMMREGISTER,LOC_FPUREGISTER,LOC_CFPUREGISTER]) then
- begin
- if not(cs_no_regalloc in current_settings.globalswitches) then
- cg.translate_register(tabstractnormalvarsym(p).localloc.register);
- if cs_asm_source in current_settings.globalswitches then
- TAsmList(list).concat(Tai_comment.Create(strpnew('Var '+tabstractnormalvarsym(p).realname+' located in register '+
- std_regname(tabstractnormalvarsym(p).localloc.register))))
- end;
- end;
- function tcgprocinfo.has_assembler_child : boolean;
- var
- hp : tprocinfo;
- begin
- result:=false;
- hp:=get_first_nestedproc;
- while assigned(hp) do
- begin
- if (hp.flags*[pi_has_assembler_block,pi_is_assembler])<>[] then
- begin
- result:=true;
- exit;
- end;
- hp:=tprocinfo(hp.next);
- end;
- end;
- procedure tcgprocinfo.generate_code;
- var
- old_current_procinfo : tprocinfo;
- oldmaxfpuregisters : longint;
- oldfilepos : tfileposinfo;
- old_current_structdef : tabstractrecorddef;
- templist : TAsmList;
- headertai : tai;
- i : integer;
- varsym : tabstractnormalvarsym;
- {RedoDFA : boolean;}
- 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;
- { No code can be generated for generic template }
- if (df_generic in procdef.defoptions) then
- internalerror(200511152);
- { The RA and Tempgen shall not be available yet }
- if assigned(tg) then
- internalerror(200309201);
- old_current_procinfo:=current_procinfo;
- oldfilepos:=current_filepos;
- old_current_structdef:=current_structdef;
- oldmaxfpuregisters:=current_settings.maxfpuregisters;
- current_procinfo:=self;
- current_filepos:=entrypos;
- current_structdef:=procdef.struct;
- templist:=TAsmList.create;
- { add parast/localst to symtablestack }
- add_to_symtablestack;
- { clear register count }
- procdef.localst.SymList.ForEachCall(@clearrefs,nil);
- procdef.parast.SymList.ForEachCall(@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 }
- procdef.parast.SymList.ForEachCall(@check_finalize_paras,nil);
- procdef.localst.SymList.ForEachCall(@check_finalize_locals,nil);
- {$if defined(x86) or defined(arm)}
- { set implicit_finally flag for if procedure is safecall }
- if (tf_safecall_exceptions in target_info.flags) and
- (procdef.proccalloption=pocall_safecall) then
- include(flags, pi_needs_implicit_finally);
- {$endif}
- { firstpass everything }
- flowcontrol:=[];
- do_firstpass(code);
- {$ifdef i386}
- procdef.fpu_used:=node_resources_fpu(code);
- if procdef.fpu_used>0 then
- include(flags,pi_uses_fpu);
- {$endif i386}
- { Print the node to tree.log }
- if paraprintnodetree=1 then
- printproc( 'after the firstpass');
- { do this before adding the entry code else the tail recursion recognition won't work,
- if this causes troubles, it must be if'ed
- }
- if (cs_opt_tailrecursion in current_settings.optimizerswitches) and
- (pi_is_recursive in flags) then
- do_opttail(code,procdef);
- if (cs_opt_nodedfa in current_settings.optimizerswitches) and
- { creating dfa is not always possible }
- ((flags*[pi_has_assembler_block,pi_uses_exceptions,pi_is_assembler,
- pi_needs_implicit_finally,pi_has_implicit_finally])=[]) then
- begin
- dfabuilder:=TDFABuilder.Create;
- dfabuilder.createdfainfo(code);
- { when life info is available, we can give more sophisticated warning about unintialized
- variables }
- { iterate through life info of the first node }
- for i:=0 to dfabuilder.nodemap.count-1 do
- begin
- if DFASetIn(code.optinfo^.life,i) then
- case tnode(dfabuilder.nodemap[i]).nodetype of
- loadn:
- begin
- varsym:=tabstractnormalvarsym(tloadnode(dfabuilder.nodemap[i]).symtableentry);
- { Give warning/note for living locals }
- if assigned(varsym.owner) and
- not(vo_is_external in varsym.varoptions) then
- begin
- if (vo_is_funcret in varsym.varoptions) then
- CGMessage(sym_w_function_result_uninitialized)
- else
- begin
- if (varsym.owner=procdef.localst) and not (vo_is_typed_const in varsym.varoptions) then
- CGMessage1(sym_w_uninitialized_local_variable,varsym.realname);
- end;
- end;
- end;
- end;
- end;
- include(flags,pi_dfaavailable);
- end;
- if (cs_opt_loopstrength in current_settings.optimizerswitches)
- { our induction variable strength reduction doesn't like
- for loops with more than one entry }
- and not(pi_has_label in current_procinfo.flags) then
- begin
- {RedoDFA:=}OptimizeInductionVariables(code);
- end;
- if cs_opt_nodecse in current_settings.optimizerswitches then
- do_optcse(code);
- { add implicit entry and exit code }
- add_entry_exit_code;
- { only do secondpass if there are no errors }
- if (ErrorCount=0) then
- begin
- create_codegen;
- { set the start offset to the start of the temp area in the stack }
- tg:=ttgobj.create;
- {$if defined(x86) or defined(arm)}
- { try to strip the stack frame }
- { set the framepointer to esp if:
- - no assembler directive, those are handled in assembler_block
- in pstatment.pas (for cases not caught by the Delphi
- exception below)
- - no exceptions are used
- - no pushes are used/esp modifications, could be:
- * outgoing parameters on the stack
- * incoming parameters on the stack
- * open arrays
- - no inline assembler
- or
- - Delphi mode
- - assembler directive
- - no pushes are used/esp modifications, could be:
- * outgoing parameters on the stack
- * incoming parameters on the stack
- * open arrays
- - no local variables
- }
- if ((po_assembler in procdef.procoptions) and
- (m_delphi in current_settings.modeswitches) and
- { localst at main_program_level is a staticsymtable }
- (procdef.localst.symtablelevel<>main_program_level) and
- (tabstractlocalsymtable(procdef.localst).count_locals = 0)) or
- ((cs_opt_stackframe in current_settings.optimizerswitches) and
- not(cs_generate_stackframes in current_settings.localswitches) and
- not(po_assembler in procdef.procoptions) and
- ((flags*[pi_has_assembler_block,pi_uses_exceptions,pi_is_assembler,
- pi_needs_implicit_finally,pi_has_implicit_finally,pi_has_stackparameter,
- pi_needs_stackframe])=[])
- )
- then
- begin
- { we need the parameter info here to determine if the procedure gets
- parameters on the stack
- calling generate_parameter_info doesn't hurt but it costs time
- (necessary to init para_stack_size)
- }
- generate_parameter_info;
- if not(procdef.stack_tainting_parameter(calleeside)) and
- not(has_assembler_child) and (para_stack_size=0) then
- begin
- { Only need to set the framepointer }
- framepointer:=NR_STACK_POINTER_REG;
- tg.direction:=1;
- end;
- end;
- {$endif}
- { Create register allocator }
- cg.init_register_allocators;
- set_first_temp_offset;
- generate_parameter_info;
- { allocate got register if needed }
- current_procinfo.allocate_got_register(aktproccode);
- { Allocate space in temp/registers for parast and localst }
- current_filepos:=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}
- current_filepos:=entrypos;
- gen_load_para_value(templist);
- { caller paraloc info is also necessary in the stackframe_entry
- code of the ppc (and possibly other processors) }
- procdef.init_paraloc_info(callerside);
- { generate code for the node tree }
- do_secondpass(code);
- aktproccode.concatlist(current_asmdata.CurrAsmList);
- { 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 }
- current_filepos:=entrypos;
- current_settings.localswitches:=entryswitches;
- cg.set_regalloc_live_range_direction(rad_backwards);
- 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 }
- current_filepos:=exitpos;
- current_settings.localswitches:=exitswitches;
- cg.set_regalloc_live_range_direction(rad_forward);
- 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,CurrExitLabel);
- 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}
- { generate symbol and save end of header position }
- current_filepos:=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 }
- current_filepos:=exitpos;
- { make sure the got/pic register doesn't get freed in the }
- { middle of a loop }
- if (cs_create_pic in current_settings.moduleswitches) and
- (pi_needs_got in current_procinfo.flags) and
- (current_procinfo.got<>NR_NO) then
- cg.a_reg_sync(aktproccode,current_procinfo.got);
- gen_free_symtable(aktproccode,procdef.localst);
- gen_free_symtable(aktproccode,procdef.parast);
- { 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);
- { Already reserve all registers for stack checking code and
- generate the call to the helper function }
- if not(tf_no_generic_stackcheck in target_info.flags) and
- (cs_check_stack in entryswitches) and
- not(po_assembler in procdef.procoptions) and
- (procdef.proctypeoption<>potype_proginit) then
- begin
- current_filepos:=entrypos;
- gen_stack_check_call(templist);
- aktproccode.insertlistafter(stackcheck_asmnode.currenttai,templist)
- end;
- { this code (got loading) comes before everything which has }
- { already been generated, so reset the info about already }
- { backwards extended registers (so their live range can be }
- { extended backwards even further if needed) }
- { This code must be }
- { a) generated after do_secondpass has been called }
- { (because pi_needs_got may be set there) }
- { b) generated before register allocation, because the }
- { got/pic register can be a virtual one }
- { c) inserted before the entry code, because the entry }
- { code may need global symbols such as init rtti }
- { d) inserted after the stackframe allocation, because }
- { this register may have to be spilled }
- cg.set_regalloc_live_range_direction(rad_backwards_reinit);
- current_filepos:=entrypos;
- { load got if necessary }
- cg.g_maybe_got_init(templist);
- aktproccode.insertlistafter(headertai,templist);
- { re-enable if more code at the end is ever generated here
- cg.set_regalloc_live_range_direction(rad_forward);
- }
- { The procedure body is finished, we can now
- allocate the registers }
- cg.do_register_allocation(aktproccode,headertai);
- { translate imag. register to their real counter parts
- this is necessary for debuginfo and verbose assembler output
- when SSA will be implented, this will be more complicated because we've to
- maintain location lists }
- current_procinfo.procdef.parast.SymList.ForEachCall(@translate_registers,templist);
- current_procinfo.procdef.localst.SymList.ForEachCall(@translate_registers,templist);
- if (cs_create_pic in current_settings.moduleswitches) and
- (pi_needs_got in current_procinfo.flags) and
- not(cs_no_regalloc in current_settings.globalswitches) and
- (current_procinfo.got<>NR_NO) then
- cg.translate_register(current_procinfo.got);
- { Add save and restore of used registers }
- current_filepos:=entrypos;
- gen_save_used_regs(templist);
- aktproccode.insertlistafter(headertai,templist);
- current_filepos:=exitpos;
- gen_restore_used_regs(aktproccode);
- { We know the size of the stack, now we can generate the
- parameter that is passed to the stack checking code }
- if not(tf_no_generic_stackcheck in target_info.flags) and
- (cs_check_stack in entryswitches) and
- not(po_assembler in procdef.procoptions) and
- (procdef.proctypeoption<>potype_proginit) then
- begin
- current_filepos:=entrypos;
- gen_stack_check_size_para(templist);
- aktproccode.insertlistafter(stackcheck_asmnode.currenttai,templist)
- end;
- { Add entry code (stack allocation) after header }
- current_filepos:=entrypos;
- gen_proc_entry_code(templist);
- aktproccode.insertlistafter(headertai,templist);
- {$if defined(x86) or defined(arm)}
- { Set return value of safecall procedure if implicit try/finally blocks are disabled }
- if not (cs_implicit_exceptions in current_settings.moduleswitches) and
- (tf_safecall_exceptions in target_info.flags) and
- (procdef.proccalloption=pocall_safecall) then
- cg.a_load_const_reg(aktproccode,OS_ADDR,0,NR_FUNCTION_RETURN_REG);
- {$endif}
- { Add exit code at the end }
- current_filepos:=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 current_settings.moduleswitches) 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 current_settings.globalswitches) then
- begin
- if (cs_opt_level1 in current_settings.optimizerswitches) and
- { do not optimize pure assembler procedures }
- not(pi_is_assembler in flags) then
- optimize(aktproccode);
- end;
- {$endif NoOpt}
- {$ifdef ARM}
- { because of the limited constant size of the arm, all data access is done pc relative }
- finalizearmcode(aktproccode,aktlocaldata);
- {$endif ARM}
- { Add end symbol and debug info }
- { this must be done after the pcrelativedata is appended else the distance calculation of
- insertpcrelativedata will be wrong, further the pc indirect data is part of the procedure
- so it should be inserted before the end symbol (FK)
- }
- current_filepos:=exitpos;
- gen_proc_symbol_end(templist);
- aktproccode.concatlist(templist);
- {$if defined(POWERPC) or defined(POWERPC64)}
- fixup_jmps(aktproccode);
- {$endif}
- { insert line debuginfo }
- if (cs_debuginfo in current_settings.moduleswitches) or
- (cs_use_lineinfo in current_settings.globalswitches) then
- current_debuginfo.insertlineinfo(aktproccode);
- { add the procedure to the al_procedures }
- maybe_new_object_file(current_asmdata.asmlists[al_procedures]);
- new_section(current_asmdata.asmlists[al_procedures],sec_code,lower(procdef.mangledname),getprocalign);
- current_asmdata.asmlists[al_procedures].concatlist(aktproccode);
- { save local data (casetable) also in the same file }
- if assigned(aktlocaldata) and
- (not aktlocaldata.empty) then
- current_asmdata.asmlists[al_procedures].concatlist(aktlocaldata);
- { only now we can remove the temps }
- tg.resettempgen;
- { stop tempgen and ra }
- tg.free;
- cg.done_register_allocators;
- destroy_codegen;
- tg:=nil;
- end;
- dfabuilder.free;
- { restore symtablestack }
- remove_from_symtablestack;
- { restore }
- templist.free;
- current_settings.maxfpuregisters:=oldmaxfpuregisters;
- current_filepos:=oldfilepos;
- current_structdef:=old_current_structdef;
- current_procinfo:=old_current_procinfo;
- end;
- procedure tcgprocinfo.add_to_symtablestack;
- begin
- { insert symtables for the class, but only if it is no nested function }
- if assigned(procdef.struct) and
- not(assigned(parent) and
- assigned(parent.procdef) and
- assigned(parent.procdef.struct)) then
- push_nested_hierarchy(procdef.struct);
- { insert parasymtable in symtablestack when parsing
- a function }
- if procdef.parast.symtablelevel>=normal_function_level then
- symtablestack.push(procdef.parast);
- { insert localsymtable, except for the main procedure
- (in that case the localst is the unit's static symtable,
- which is already on the stack) }
- if procdef.localst.symtablelevel>=normal_function_level then
- symtablestack.push(procdef.localst);
- end;
- procedure tcgprocinfo.remove_from_symtablestack;
- begin
- { remove localsymtable }
- if procdef.localst.symtablelevel>=normal_function_level then
- symtablestack.pop(procdef.localst);
- { remove parasymtable }
- if procdef.parast.symtablelevel>=normal_function_level then
- symtablestack.pop(procdef.parast);
- { remove symtables for the class, but only if it is no nested function }
- if assigned(procdef.struct) and
- not(assigned(parent) and
- assigned(parent.procdef) and
- assigned(parent.procdef.struct)) then
- pop_nested_hierarchy(procdef.struct);
- 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 (pi_has_assembler_block in current_procinfo.flags) then
- begin
- Message1(parser_w_not_supported_for_inline,'assembler');
- Message(parser_w_inlining_disabled);
- exit;
- end;
- for i:=0 to procdef.paras.count-1 do
- begin
- currpara:=tparavarsym(procdef.paras[i]);
- case currpara.vardef.typ of
- formaldef :
- begin
- if (currpara.varspez in [vs_out,vs_var,vs_const,vs_constref]) then
- begin
- Message1(parser_w_not_supported_for_inline,'formal parameter');
- Message(parser_w_inlining_disabled);
- exit;
- end;
- end;
- arraydef :
- begin
- if is_array_of_const(currpara.vardef) or
- is_variant_array(currpara.vardef) then
- begin
- Message1(parser_w_not_supported_for_inline,'array of const');
- Message(parser_w_inlining_disabled);
- exit;
- end;
- { open arrays might need 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 is_open_array(currpara.vardef) then
- begin
- Message1(parser_w_not_supported_for_inline,'open array');
- Message(parser_w_inlining_disabled);
- exit;
- end;
- end;
- end;
- end;
- result:=true;
- end;
- procedure tcgprocinfo.parse_body;
- var
- old_current_procinfo : tprocinfo;
- old_block_type : tblock_type;
- st : TSymtable;
- old_current_structdef: tabstractrecorddef;
- old_current_genericdef,
- old_current_specializedef: tstoreddef;
- begin
- old_current_procinfo:=current_procinfo;
- old_block_type:=block_type;
- old_current_structdef:=current_structdef;
- old_current_genericdef:=current_genericdef;
- old_current_specializedef:=current_specializedef;
- current_procinfo:=self;
- current_structdef:=procdef.struct;
- if assigned(current_structdef) and (df_generic in current_structdef.defoptions) then
- current_genericdef:=current_structdef;
- if assigned(current_structdef) and (df_specialization in current_structdef.defoptions) then
- current_specializedef:=current_structdef;
- { calculate the lexical level }
- if procdef.parast.symtablelevel>maxnesting then
- Message(parser_e_too_much_lexlevel);
- block_type:=bt_body;
- {$ifdef state_tracking}
- { aktstate:=Tstate_storage.create;}
- {$endif state_tracking}
- { allocate the symbol for this procedure }
- alloc_proc_symbol(procdef);
- { add parast/localst to symtablestack }
- add_to_symtablestack;
- { save entry info }
- entrypos:=current_filepos;
- entryswitches:=current_settings.localswitches;
- if (df_generic in procdef.defoptions) then
- begin
- { start token recorder for generic template }
- procdef.initgeneric;
- current_scanner.startrecordtokens(procdef.generictokenbuf);
- end;
- { parse the code ... }
- code:=block(current_module.islibrary);
- if (df_generic in procdef.defoptions) then
- begin
- { stop token recorder for generic template }
- current_scanner.stoprecordtokens;
- { Give an error for accesses in the static symtable that aren't visible
- outside the current unit }
- st:=procdef.owner;
- while (st.symtabletype=ObjectSymtable) do
- st:=st.defowner.owner;
- if (pi_uses_static_symtable in flags) and
- (st.symtabletype<>staticsymtable) then
- Comment(V_Error,'Global Generic template references static symtable');
- end;
- { save exit info }
- exitswitches:=current_settings.localswitches;
- 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_typecheckpass(code);
- end;
- { Check for unused labels, forwards, symbols for procedures. Static
- symtable is checked in pmodules.
- The check must be done after the typecheckpass }
- 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;
- { 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 (po_inline in procdef.procoptions) 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;
- { 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( 'after parsing');
- { ... remove symbol tables }
- remove_from_symtablestack;
- {$ifdef state_tracking}
- { aktstate.destroy;}
- {$endif state_tracking}
- current_structdef:=old_current_structdef;
- current_genericdef:=old_current_genericdef;
- current_specializedef:=old_current_specializedef;
- current_procinfo:=old_current_procinfo;
- { Restore old state }
- block_type:=old_block_type;
- end;
- {****************************************************************************
- PROCEDURE/FUNCTION PARSING
- ****************************************************************************}
- procedure check_init_paras(p:TObject;arg:pointer);
- begin
- if tsym(p).typ<>paravarsym then
- exit;
- with tparavarsym(p) do
- if is_managed_type(vardef) and
- (varspez in [vs_value,vs_out]) then
- include(current_procinfo.flags,pi_do_call);
- end;
- procedure read_proc_body(old_current_procinfo:tprocinfo;pd:tprocdef);
- {
- 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.get_first_nestedproc);
- while assigned(hpi) do
- begin
- do_generate_code(hpi);
- hpi:=tcgprocinfo(hpi.next);
- end;
- pi.resetprocdef;
- end;
- var
- oldfailtokenmode : tmodeswitch;
- isnestedproc : boolean;
- 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 current_settings.globalswitches 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.SymList.ForEachCall(@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;
- { 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.has_nestedprocs then
- begin
- if (df_generic in current_procinfo.procdef.defoptions) then
- Comment(V_Error,'Generic methods cannot have nested procedures')
- else
- if (po_inline in current_procinfo.procdef.procoptions) then
- begin
- Message1(parser_w_not_supported_for_inline,'nested procedures');
- Message(parser_w_inlining_disabled);
- exclude(current_procinfo.procdef.procoptions,po_inline);
- end;
- end;
- { 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 not isnestedproc then
- begin
- if not(df_generic in current_procinfo.procdef.defoptions) then
- 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;
- { For specialization we didn't record the last semicolon. Moving this parsing
- into the parse_body routine is not done because of having better file position
- information available }
- if not(df_specialization in current_procinfo.procdef.defoptions) then
- consume(_SEMICOLON);
- if not isnestedproc then
- { current_procinfo is checked for nil later on }
- freeandnil(current_procinfo);
- end;
- procedure read_proc(isclassmethod:boolean);
- {
- Parses the procedure directives, then parses the procedure body, then
- generates the code for it
- }
- var
- old_current_procinfo : tprocinfo;
- old_current_structdef: tabstractrecorddef;
- old_current_genericdef,
- old_current_specializedef: tstoreddef;
- pdflags : tpdflags;
- pd,firstpd : tprocdef;
- s : string;
- begin
- { save old state }
- old_current_procinfo:=current_procinfo;
- old_current_structdef:=current_structdef;
- old_current_genericdef:=current_genericdef;
- old_current_specializedef:=current_specializedef;
- { reset current_procinfo.procdef to nil to be sure that nothing is writing
- to another procdef }
- current_procinfo:=nil;
- current_structdef:=nil;
- current_genericdef:=nil;
- current_specializedef:=nil;
- { parse procedure declaration }
- pd:=parse_proc_dec(isclassmethod,old_current_structdef);
- { 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
- create_smartlink or
- {
- taking addresses of static procedures goes wrong
- if they aren't global when pic is used (FK)
- }
- (cs_create_pic in current_settings.moduleswitches) 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,pd.deprecatedmsg) 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.struct) and
- (not assigned(old_current_structdef)) 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 }
- firstpd:=tprocdef(tprocsym(pd.procsym).ProcdefList[0]);
- if (not pd.forwarddef) and
- (not pd.interfacedef) and
- (tprocsym(pd.procsym).ProcdefList.Count>1) and
- firstpd.forwarddef and
- firstpd.interfacedef and
- not(tprocsym(pd.procsym).ProcdefList.Count>2) and
- { don't give an error if it may be an overload }
- not(m_fpc in current_settings.modeswitches) and
- (not(po_overload in pd.procoptions) or
- not(po_overload in firstpd.procoptions)) 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
- read_proc_body(old_current_procinfo,pd);
- 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)
- { it is unclear to me what's the use of the following condition,
- so commented out, see also issue #18371 (FK)
- and
- not(
- assigned(pd.import_dll) and
- (target_info.system in [system_i386_wdosx,
- system_arm_wince,system_i386_wince])
- ) } then
- begin
- s:=proc_get_importname(pd);
- if s<>'' then
- gen_external_stub(current_asmdata.asmlists[al_procedures],pd,s);
- end;
- { Import DLL specified? }
- if assigned(pd.import_dll) then
- begin
- if assigned (pd.import_name) then
- current_module.AddExternalImport(pd.import_dll^,
- pd.import_name^,proc_get_importname(pd),
- pd.import_nr,false,false)
- else
- current_module.AddExternalImport(pd.import_dll^,
- proc_get_importname(pd),proc_get_importname(pd),
- pd.import_nr,false,true);
- end
- else
- begin
- { add import name to external list for DLL scanning }
- if tf_has_dllscanner in target_info.flags then
- current_module.dllscannerinputlist.Add(proc_get_importname(pd),pd);
- end;
- end;
- end;
- { make sure that references to forward-declared functions are not }
- { treated as references to external symbols, needed for darwin. }
- { make sure we don't change the binding of real external symbols }
- if not(po_external in pd.procoptions) then
- begin
- if (po_global in pd.procoptions) or
- (cs_profile in current_settings.moduleswitches) then
- current_asmdata.DefineAsmSymbol(pd.mangledname,AB_GLOBAL,AT_FUNCTION)
- else
- current_asmdata.DefineAsmSymbol(pd.mangledname,AB_LOCAL,AT_FUNCTION);
- end;
- current_structdef:=old_current_structdef;
- current_genericdef:=old_current_genericdef;
- current_specializedef:=old_current_specializedef;
- current_procinfo:=old_current_procinfo;
- end;
- {****************************************************************************
- DECLARATION PARSING
- ****************************************************************************}
- { search in symtablestack for not complete classes }
- procedure check_forward_class(p:TObject;arg:pointer);
- begin
- if (tsym(p).typ=typesym) and
- (ttypesym(p).typedef.typ=objectdef) and
- (oo_is_forward in tobjectdef(ttypesym(p).typedef).objectoptions) then
- MessagePos1(tsym(p).fileinfo,sym_e_forward_type_not_resolved,tsym(p).realname);
- end;
- procedure read_declarations(islibrary : boolean);
- var
- is_classdef:boolean;
- begin
- is_classdef:=false;
- 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;
- _CLASS:
- begin
- is_classdef:=false;
- if try_to_consume(_CLASS) then
- begin
- { class modifier is only allowed for procedures, functions, }
- { constructors, destructors, fields and properties }
- if not(token in [_FUNCTION,_PROCEDURE,_PROPERTY,_VAR,_CONSTRUCTOR,_DESTRUCTOR,_OPERATOR]) and
- not((token=_ID) and (idtoken=_OPERATOR)) then
- Message(parser_e_procedure_or_function_expected);
- if is_interface(current_structdef) then
- Message(parser_e_no_static_method_in_interfaces)
- else
- { class methods are also allowed for Objective-C protocols }
- is_classdef:=true;
- end;
- end;
- _CONSTRUCTOR,
- _DESTRUCTOR,
- _FUNCTION,
- _PROCEDURE,
- _OPERATOR:
- begin
- read_proc(is_classdef);
- is_classdef:=false;
- end;
- _EXPORTS:
- begin
- if (current_procinfo.procdef.localst.symtablelevel>main_program_level) then
- begin
- Message(parser_e_syntax_error);
- consume_all_until(_SEMICOLON);
- end
- else if islibrary or
- (target_info.system in systems_unit_program_exports) then
- read_exports
- else
- begin
- Message(parser_w_unsupported_feature);
- consume(_BEGIN);
- end;
- end
- else
- begin
- case idtoken of
- _RESOURCESTRING:
- begin
- { m_class is needed, because the resourcestring
- loading is in the ObjPas unit }
- { if (m_class in current_settings.modeswitches) then}
- resourcestring_dec
- { else
- break;}
- end;
- _OPERATOR:
- begin
- if is_classdef then
- begin
- read_proc(is_classdef);
- is_classdef:=false;
- end
- else
- break;
- end;
- _PROPERTY:
- begin
- if (m_fpc in current_settings.modeswitches) then
- begin
- property_dec(is_classdef);
- is_classdef:=false;
- end
- 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 current_settings.modeswitches) then
- current_procinfo.procdef.localst.SymList.ForEachCall(@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(false);
- else
- begin
- case idtoken of
- _RESOURCESTRING :
- resourcestring_dec;
- _PROPERTY:
- begin
- if (m_fpc in current_settings.modeswitches) then
- property_dec(false)
- 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 current_settings.modeswitches) then
- symtablestack.top.SymList.ForEachCall(@check_forward_class,nil);
- end;
- {****************************************************************************
- SPECIALIZATION BODY GENERATION
- ****************************************************************************}
- procedure specialize_objectdefs(p:TObject;arg:pointer);
- var
- i : longint;
- hp : tdef;
- oldcurrent_filepos : tfileposinfo;
- oldsymtablestack : tsymtablestack;
- oldextendeddefs : TFPHashObjectList;
- pu : tused_unit;
- hmodule : tmodule;
- specobj : tabstractrecorddef;
- begin
- if not((tsym(p).typ=typesym) and
- (ttypesym(p).typedef.typesym=tsym(p)) and
- (ttypesym(p).typedef.typ in [objectdef,recorddef]) and
- (df_specialization in ttypesym(p).typedef.defoptions)
- ) then
- exit;
- { Setup symtablestack a definition time }
- specobj:=tabstractrecorddef(ttypesym(p).typedef);
- if not (is_class_or_object(specobj) or is_record(specobj)) then
- exit;
- oldsymtablestack:=symtablestack;
- oldextendeddefs:=current_module.extendeddefs;
- current_module.extendeddefs:=TFPHashObjectList.create(true);
- symtablestack:=tdefawaresymtablestack.create;
- if not assigned(specobj.genericdef) then
- internalerror(200705151);
- hmodule:=find_module_from_symtable(specobj.genericdef.owner);
- if hmodule=nil then
- internalerror(200705152);
- pu:=tused_unit(hmodule.used_units.first);
- while assigned(pu) do
- begin
- if not assigned(pu.u.globalsymtable) then
- internalerror(200705153);
- symtablestack.push(pu.u.globalsymtable);
- pu:=tused_unit(pu.next);
- end;
- if assigned(hmodule.globalsymtable) then
- symtablestack.push(hmodule.globalsymtable);
- if assigned(hmodule.localsymtable) then
- symtablestack.push(hmodule.localsymtable);
- { procedure definitions for classes or objects }
- for i:=0 to specobj.symtable.DefList.Count-1 do
- begin
- hp:=tdef(specobj.symtable.DefList[i]);
- if hp.typ=procdef then
- begin
- if assigned(tprocdef(hp).genericdef) and
- (tprocdef(hp).genericdef.typ=procdef) and
- assigned(tprocdef(tprocdef(hp).genericdef).generictokenbuf) then
- begin
- oldcurrent_filepos:=current_filepos;
- current_filepos:=tprocdef(tprocdef(hp).genericdef).fileinfo;
- { use the index the module got from the current compilation process }
- current_filepos.moduleindex:=hmodule.unit_index;
- current_tokenpos:=current_filepos;
- current_scanner.startreplaytokens(tprocdef(tprocdef(hp).genericdef).generictokenbuf);
- read_proc_body(nil,tprocdef(hp));
- current_filepos:=oldcurrent_filepos;
- end
- else
- MessagePos1(tprocdef(hp).fileinfo,sym_e_forward_not_resolved,tprocdef(hp).fullprocname(false));
- end;
- end;
- { Restore symtablestack }
- current_module.extendeddefs.free;
- current_module.extendeddefs:=oldextendeddefs;
- symtablestack.free;
- symtablestack:=oldsymtablestack;
- end;
- procedure generate_specialization_procs;
- begin
- if assigned(current_module.globalsymtable) then
- current_module.globalsymtable.SymList.ForEachCall(@specialize_objectdefs,nil);
- if assigned(current_module.localsymtable) then
- current_module.localsymtable.SymList.ForEachCall(@specialize_objectdefs,nil);
- end;
- end.
|