psub.pas 109 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475247624772478247924802481248224832484248524862487248824892490249124922493249424952496249724982499250025012502250325042505250625072508250925102511251225132514251525162517251825192520252125222523252425252526252725282529253025312532253325342535253625372538253925402541254225432544254525462547254825492550255125522553255425552556255725582559256025612562256325642565256625672568256925702571257225732574257525762577257825792580258125822583258425852586258725882589259025912592259325942595259625972598259926002601260226032604260526062607260826092610261126122613261426152616261726182619262026212622262326242625262626272628262926302631263226332634263526362637263826392640264126422643264426452646264726482649265026512652265326542655265626572658265926602661266226632664266526662667266826692670267126722673267426752676267726782679268026812682268326842685268626872688268926902691269226932694269526962697269826992700270127022703270427052706270727082709271027112712271327142715271627172718271927202721272227232724272527262727272827292730273127322733273427352736273727382739274027412742
  1. {
  2. Copyright (c) 1998-2002 by Florian Klaempfl, Daniel Mantione
  3. Does the parsing and codegeneration at subroutine level
  4. This program is free software; you can redistribute it and/or modify
  5. it under the terms of the GNU General Public License as published by
  6. the Free Software Foundation; either version 2 of the License, or
  7. (at your option) any later version.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  11. GNU General Public License for more details.
  12. You should have received a copy of the GNU General Public License
  13. along with this program; if not, write to the Free Software
  14. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  15. ****************************************************************************
  16. }
  17. unit psub;
  18. {$i fpcdefs.inc}
  19. { $define debug_eh}
  20. interface
  21. uses
  22. globals,
  23. node,nbas,
  24. symdef,procinfo,optdfa;
  25. type
  26. tcgprocinfo = class(tprocinfo)
  27. private
  28. procedure CreateInlineInfo;
  29. { returns the node which is the start of the user code, this is needed by the dfa }
  30. function GetUserCode: tnode;
  31. procedure maybe_add_constructor_wrapper(var tocode: tnode; withexceptblock: boolean);
  32. procedure add_entry_exit_code;
  33. procedure setup_tempgen;
  34. public
  35. { code for the subroutine as tree }
  36. code : tnode;
  37. { positions in the tree for init/final }
  38. entry_asmnode,
  39. loadpara_asmnode,
  40. exitlabel_asmnode,
  41. stackcheck_asmnode,
  42. init_asmnode : tasmnode;
  43. temps_finalized : boolean;
  44. dfabuilder : TDFABuilder;
  45. destructor destroy;override;
  46. function calc_stackframe_size : longint;override;
  47. procedure printproc(pass:string);
  48. procedure generate_code;
  49. procedure generate_code_tree;
  50. procedure generate_exceptfilter(nestedpi: tcgprocinfo);
  51. procedure resetprocdef;
  52. procedure add_to_symtablestack;
  53. procedure remove_from_symtablestack;
  54. procedure parse_body;
  55. function has_assembler_child : boolean;
  56. procedure set_eh_info; override;
  57. end;
  58. procedure printnode_reset;
  59. { reads the declaration blocks }
  60. procedure read_declarations(islibrary : boolean);
  61. { reads declarations in the interface part of a unit }
  62. procedure read_interface_declarations;
  63. { reads any routine in the implementation, or a non-method routine
  64. declaration in the interface (depending on whether or not parse_only is
  65. true) }
  66. procedure read_proc(isclassmethod:boolean; usefwpd: tprocdef;isgeneric:boolean);
  67. { parses only the body of a non nested routine; needs a correctly setup pd }
  68. procedure read_proc_body(pd:tprocdef);
  69. procedure import_external_proc(pd:tprocdef);
  70. implementation
  71. uses
  72. sysutils,
  73. { common }
  74. cutils, cmsgs, cclasses,
  75. { global }
  76. globtype,tokens,verbose,comphook,constexp,
  77. systems,cpubase,aasmbase,aasmtai,aasmdata,
  78. { symtable }
  79. symconst,symbase,symsym,symtype,symtable,defutil,defcmp,symcreat,
  80. paramgr,
  81. fmodule,
  82. { pass 1 }
  83. nutils,ngenutil,nld,ncal,ncon,nflw,nadd,ncnv,nmem,
  84. pass_1,
  85. {$ifdef state_tracking}
  86. nstate,
  87. {$endif state_tracking}
  88. { pass 2 }
  89. {$ifndef NOPASS2}
  90. pass_2,
  91. {$endif}
  92. { parser }
  93. scanner,gendef,
  94. pbase,pstatmnt,pdecl,pdecsub,pexports,pgenutil,pparautl,
  95. { codegen }
  96. tgobj,cgbase,cgobj,hlcgobj,hlcgcpu,dbgbase,
  97. ncgflw,
  98. ncgutil,
  99. optbase,
  100. opttail,
  101. optcse,
  102. optloop,
  103. optconstprop,
  104. optdeadstore,
  105. optloadmodifystore,
  106. optutils
  107. {$if defined(arm)}
  108. ,cpuinfo
  109. {$endif arm}
  110. {$ifndef NOOPT}
  111. ,aopt
  112. {$endif}
  113. ;
  114. function checknodeinlining(procdef: tprocdef): boolean;
  115. procedure _no_inline(const reason: TMsgStr);
  116. begin
  117. include(procdef.implprocoptions,pio_inline_not_possible);
  118. Message1(parser_n_not_supported_for_inline,reason);
  119. Message(parser_h_inlining_disabled);
  120. end;
  121. var
  122. i : integer;
  123. currpara : tparavarsym;
  124. begin
  125. result := false;
  126. { this code will never be used (only specialisations can be inlined),
  127. and moreover contains references to defs that are not stored in the
  128. ppu file }
  129. if df_generic in current_procinfo.procdef.defoptions then
  130. exit;
  131. if pi_has_assembler_block in current_procinfo.flags then
  132. begin
  133. _no_inline('assembler');
  134. exit;
  135. end;
  136. if (pi_has_global_goto in current_procinfo.flags) or
  137. (pi_has_interproclabel in current_procinfo.flags) then
  138. begin
  139. _no_inline('global goto');
  140. exit;
  141. end;
  142. if pi_has_nested_exit in current_procinfo.flags then
  143. begin
  144. _no_inline('nested exit');
  145. exit;
  146. end;
  147. if pi_calls_c_varargs in current_procinfo.flags then
  148. begin
  149. _no_inline('called C-style varargs functions');
  150. exit;
  151. end;
  152. { the compiler cannot handle inherited in inlined subroutines because
  153. it tries to search for self in the symtable, however, the symtable
  154. is not available }
  155. if pi_has_inherited in current_procinfo.flags then
  156. begin
  157. _no_inline('inherited');
  158. exit;
  159. end;
  160. if pio_nested_access in procdef.implprocoptions then
  161. begin
  162. _no_inline('access to local from nested scope');
  163. exit;
  164. end;
  165. { We can't support inlining for procedures that have nested
  166. procedures because the nested procedures use a fixed offset
  167. for accessing locals in the parent procedure (PFV) }
  168. if current_procinfo.has_nestedprocs then
  169. begin
  170. _no_inline('nested procedures');
  171. exit;
  172. end;
  173. for i:=0 to procdef.paras.count-1 do
  174. begin
  175. currpara:=tparavarsym(procdef.paras[i]);
  176. case currpara.vardef.typ of
  177. formaldef :
  178. begin
  179. if (currpara.varspez in [vs_out,vs_var,vs_const,vs_constref]) then
  180. begin
  181. _no_inline('formal parameter');
  182. exit;
  183. end;
  184. end;
  185. arraydef :
  186. begin
  187. if is_array_of_const(currpara.vardef) or
  188. is_variant_array(currpara.vardef) then
  189. begin
  190. _no_inline('array of const');
  191. exit;
  192. end;
  193. { open arrays might need re-basing of the index, i.e. if you pass
  194. an array[1..10] as open array, you have to add 1 to all index operations
  195. if you directly inline it }
  196. if is_open_array(currpara.vardef) then
  197. begin
  198. _no_inline('open array');
  199. exit;
  200. end;
  201. end;
  202. end;
  203. end;
  204. result:=true;
  205. end;
  206. {****************************************************************************
  207. PROCEDURE/FUNCTION BODY PARSING
  208. ****************************************************************************}
  209. procedure initializedefaultvars(p:TObject;arg:pointer);
  210. var
  211. b : tblocknode;
  212. begin
  213. if tsym(p).typ<>localvarsym then
  214. exit;
  215. with tabstractnormalvarsym(p) do
  216. begin
  217. if (vo_is_default_var in varoptions) and (vardef.size>0) then
  218. begin
  219. b:=tblocknode(arg);
  220. b.left:=cstatementnode.create(
  221. ccallnode.createintern('fpc_zeromem',
  222. ccallparanode.create(
  223. cordconstnode.create(vardef.size,sizeuinttype,false),
  224. ccallparanode.create(
  225. caddrnode.create_internal(
  226. cloadnode.create(tsym(p),tsym(p).owner)),
  227. nil
  228. )
  229. )
  230. ),
  231. b.left);
  232. end;
  233. end;
  234. end;
  235. procedure initializevars(p:TObject;arg:pointer);
  236. var
  237. b : tblocknode;
  238. begin
  239. if not (tsym(p).typ in [localvarsym,staticvarsym]) then
  240. exit;
  241. with tabstractnormalvarsym(p) do
  242. begin
  243. if assigned(defaultconstsym) then
  244. begin
  245. b:=tblocknode(arg);
  246. b.left:=cstatementnode.create(
  247. cassignmentnode.create(
  248. cloadnode.create(tsym(p),tsym(p).owner),
  249. cloadnode.create(defaultconstsym,defaultconstsym.owner)),
  250. b.left);
  251. end
  252. else
  253. initializedefaultvars(p,arg);
  254. end;
  255. end;
  256. procedure check_finalize_paras(p:TObject;arg:pointer);
  257. begin
  258. if (tsym(p).typ=paravarsym) then
  259. begin
  260. if tparavarsym(p).needs_finalization then
  261. begin
  262. include(current_procinfo.flags,pi_needs_implicit_finally);
  263. include(current_procinfo.flags,pi_do_call);
  264. end;
  265. if (tparavarsym(p).varspez in [vs_value,vs_out]) and
  266. (cs_create_pic in current_settings.moduleswitches) and
  267. (tf_pic_uses_got in target_info.flags) and
  268. is_rtti_managed_type(tparavarsym(p).vardef) then
  269. include(current_procinfo.flags,pi_needs_got);
  270. end;
  271. end;
  272. procedure check_finalize_locals(p:TObject;arg:pointer);
  273. begin
  274. { include the result: it needs to be finalized in case an exception }
  275. { occurs }
  276. if (tsym(p).typ=localvarsym) and
  277. (tlocalvarsym(p).refs>0) and
  278. is_managed_type(tlocalvarsym(p).vardef) then
  279. begin
  280. include(current_procinfo.flags,pi_needs_implicit_finally);
  281. include(current_procinfo.flags,pi_do_call);
  282. if is_rtti_managed_type(tlocalvarsym(p).vardef) and
  283. (cs_create_pic in current_settings.moduleswitches) and
  284. (tf_pic_uses_got in target_info.flags) then
  285. include(current_procinfo.flags,pi_needs_got);
  286. end;
  287. end;
  288. function block(islibrary : boolean) : tnode;
  289. var
  290. oldfilepos: tfileposinfo;
  291. begin
  292. { parse const,types and vars }
  293. read_declarations(islibrary);
  294. { do we have an assembler block without the po_assembler?
  295. we should allow this for Delphi compatibility (PFV) }
  296. if (token=_ASM) and (m_delphi in current_settings.modeswitches) then
  297. include(current_procinfo.procdef.procoptions,po_assembler);
  298. { Handle assembler block different }
  299. if (po_assembler in current_procinfo.procdef.procoptions) then
  300. begin
  301. block:=assembler_block;
  302. exit;
  303. end;
  304. {Unit initialization?.}
  305. if (
  306. assigned(current_procinfo.procdef.localst) and
  307. (current_procinfo.procdef.localst.symtablelevel=main_program_level) and
  308. (current_module.is_unit or islibrary)
  309. ) then
  310. begin
  311. if (token=_END) then
  312. begin
  313. consume(_END);
  314. { We need at least a node, else the entry/exit code is not
  315. generated and thus no PASCALMAIN symbol which we need (PFV) }
  316. if islibrary then
  317. block:=cnothingnode.create
  318. else
  319. block:=nil;
  320. end
  321. else
  322. begin
  323. if token=_INITIALIZATION then
  324. begin
  325. { The library init code is already called and does not
  326. need to be in the initfinal table (PFV) }
  327. block:=statement_block(_INITIALIZATION);
  328. end
  329. else if token=_FINALIZATION then
  330. begin
  331. { when a unit has only a finalization section, we can come to this
  332. point when we try to read the nonh existing initalization section
  333. so we've to check if we are really try to parse the finalization }
  334. if current_procinfo.procdef.proctypeoption=potype_unitfinalize then
  335. block:=statement_block(_FINALIZATION)
  336. else
  337. block:=nil;
  338. end
  339. else
  340. block:=statement_block(_BEGIN);
  341. end;
  342. end
  343. else
  344. begin
  345. { parse routine body }
  346. block:=statement_block(_BEGIN);
  347. { initialized variables }
  348. if current_procinfo.procdef.localst.symtabletype=localsymtable then
  349. begin
  350. { initialization of local variables with their initial
  351. values: part of function entry }
  352. oldfilepos:=current_filepos;
  353. current_filepos:=current_procinfo.entrypos;
  354. current_procinfo.procdef.localst.SymList.ForEachCall(@initializevars,block);
  355. current_filepos:=oldfilepos;
  356. end
  357. else if current_procinfo.procdef.localst.symtabletype=staticsymtable then
  358. begin
  359. { for program and unit initialization code we also need to
  360. initialize the local variables used of Default() }
  361. oldfilepos:=current_filepos;
  362. current_filepos:=current_procinfo.entrypos;
  363. current_procinfo.procdef.localst.SymList.ForEachCall(@initializedefaultvars,block);
  364. current_filepos:=oldfilepos;
  365. end;
  366. if assigned(current_procinfo.procdef.parentfpstruct) then
  367. begin
  368. { we only do this after the code has been parsed because
  369. otherwise for-loop counters moved to the struct cause
  370. errors; we still do it nevertheless to prevent false
  371. "unused" symbols warnings and to assist debug info
  372. generation }
  373. redirect_parentfpstruct_local_syms(current_procinfo.procdef);
  374. { finish the parentfpstruct (add padding, ...) }
  375. finish_parentfpstruct(current_procinfo.procdef);
  376. end;
  377. end;
  378. end;
  379. {****************************************************************************
  380. PROCEDURE/FUNCTION COMPILING
  381. ****************************************************************************}
  382. procedure printnode_reset;
  383. begin
  384. assign(printnodefile,treelogfilename);
  385. {$push}{$I-}
  386. rewrite(printnodefile);
  387. {$pop}
  388. if ioresult<>0 then
  389. begin
  390. Comment(V_Error,'Error creating '+treelogfilename);
  391. exit;
  392. end;
  393. close(printnodefile);
  394. end;
  395. procedure add_label_init(p:TObject;arg:pointer);
  396. begin
  397. if tstoredsym(p).typ=labelsym then
  398. begin
  399. addstatement(tstatementnode(arg^),
  400. cifnode.create(caddnode.create(equaln,
  401. ccallnode.createintern('fpc_setjmp',
  402. ccallparanode.create(cloadnode.create(tlabelsym(p).jumpbuf,tlabelsym(p).jumpbuf.owner),nil)),
  403. cordconstnode.create(1,sinttype,true))
  404. ,cgotonode.create(tlabelsym(p)),nil)
  405. );
  406. end;
  407. end;
  408. function generate_bodyentry_block:tnode;
  409. var
  410. srsym : tsym;
  411. para : tcallparanode;
  412. call : tcallnode;
  413. newstatement : tstatementnode;
  414. def : tabstractrecorddef;
  415. begin
  416. result:=internalstatements(newstatement);
  417. if assigned(current_structdef) then
  418. begin
  419. { a constructor needs a help procedure }
  420. if (current_procinfo.procdef.proctypeoption=potype_constructor) then
  421. begin
  422. if is_class(current_structdef) or
  423. (
  424. is_objectpascal_helper(current_structdef) and
  425. is_class(tobjectdef(current_structdef).extendeddef)
  426. ) then
  427. begin
  428. if is_objectpascal_helper(current_structdef) then
  429. def:=tabstractrecorddef(tobjectdef(current_structdef).extendeddef)
  430. else
  431. def:=current_structdef;
  432. srsym:=search_struct_member(def,'NEWINSTANCE');
  433. if assigned(srsym) and
  434. (srsym.typ=procsym) then
  435. begin
  436. { if vmt=1 then newinstance }
  437. addstatement(newstatement,cifnode.create(
  438. caddnode.create_internal(equaln,
  439. ctypeconvnode.create_internal(
  440. load_vmt_pointer_node,
  441. voidpointertype),
  442. cpointerconstnode.create(1,voidpointertype)),
  443. cassignmentnode.create(
  444. ctypeconvnode.create_internal(
  445. load_self_pointer_node,
  446. voidpointertype),
  447. ccallnode.create(nil,tprocsym(srsym),srsym.owner,
  448. ctypeconvnode.create_internal(load_self_pointer_node,cclassrefdef.create(current_structdef)),
  449. [],nil)),
  450. nil));
  451. end
  452. else
  453. internalerror(200305108);
  454. end
  455. else
  456. if is_object(current_structdef) then
  457. begin
  458. { parameter 3 : vmt_offset }
  459. { parameter 2 : address of pointer to vmt,
  460. this is required to allow setting the vmt to -1 to indicate
  461. that memory was allocated }
  462. { parameter 1 : self pointer }
  463. para:=ccallparanode.create(
  464. cordconstnode.create(tobjectdef(current_structdef).vmt_offset,s32inttype,false),
  465. ccallparanode.create(
  466. ctypeconvnode.create_internal(
  467. load_vmt_pointer_node,
  468. voidpointertype),
  469. ccallparanode.create(
  470. ctypeconvnode.create_internal(
  471. load_self_pointer_node,
  472. voidpointertype),
  473. nil)));
  474. addstatement(newstatement,cassignmentnode.create(
  475. ctypeconvnode.create_internal(
  476. load_self_pointer_node,
  477. voidpointertype),
  478. ccallnode.createintern('fpc_help_constructor',para)));
  479. end
  480. else
  481. if is_javaclass(current_structdef) or
  482. ((target_info.system in systems_jvm) and
  483. is_record(current_structdef)) then
  484. begin
  485. if (current_procinfo.procdef.proctypeoption=potype_constructor) and
  486. not current_procinfo.ConstructorCallingConstructor then
  487. begin
  488. { call inherited constructor }
  489. if is_javaclass(current_structdef) then
  490. srsym:=search_struct_member_no_helper(tobjectdef(current_structdef).childof,'CREATE')
  491. else
  492. srsym:=search_struct_member_no_helper(java_fpcbaserecordtype,'CREATE');
  493. if assigned(srsym) and
  494. (srsym.typ=procsym) then
  495. begin
  496. call:=ccallnode.create(nil,tprocsym(srsym),srsym.owner,load_self_node,[cnf_inherited],nil);
  497. exclude(tcallnode(call).callnodeflags,cnf_return_value_used);
  498. addstatement(newstatement,call);
  499. end
  500. else
  501. internalerror(2011010312);
  502. end;
  503. end
  504. else
  505. if not is_record(current_structdef) and
  506. not (
  507. is_objectpascal_helper(current_structdef) and
  508. (tobjectdef(current_structdef).extendeddef.typ<>objectdef)
  509. ) then
  510. internalerror(200305103);
  511. { if self=nil then exit
  512. calling fail instead of exit is useless because
  513. there is nothing to dispose (PFV) }
  514. if is_class_or_object(current_structdef) then
  515. addstatement(newstatement,cifnode.create(
  516. caddnode.create(equaln,
  517. load_self_pointer_node,
  518. cnilnode.create),
  519. cexitnode.create(nil),
  520. nil));
  521. end;
  522. { maybe call BeforeDestruction for classes }
  523. if (current_procinfo.procdef.proctypeoption=potype_destructor) and
  524. is_class(current_structdef) then
  525. begin
  526. srsym:=search_struct_member(current_structdef,'BEFOREDESTRUCTION');
  527. if assigned(srsym) and
  528. (srsym.typ=procsym) then
  529. begin
  530. { if vmt>0 then beforedestruction }
  531. addstatement(newstatement,cifnode.create(
  532. caddnode.create(gtn,
  533. ctypeconvnode.create_internal(
  534. load_vmt_pointer_node,ptrsinttype),
  535. ctypeconvnode.create_internal(
  536. cnilnode.create,ptrsinttype)),
  537. ccallnode.create(nil,tprocsym(srsym),srsym.owner,load_self_node,[],nil),
  538. nil));
  539. end
  540. else
  541. internalerror(200305104);
  542. end;
  543. end;
  544. if m_non_local_goto in current_settings.modeswitches then
  545. tsymtable(current_procinfo.procdef.localst).SymList.ForEachCall(@add_label_init,@newstatement);
  546. end;
  547. function generate_bodyexit_block:tnode;
  548. var
  549. srsym : tsym;
  550. para : tcallparanode;
  551. newstatement : tstatementnode;
  552. oldlocalswitches: tlocalswitches;
  553. begin
  554. result:=internalstatements(newstatement);
  555. if assigned(current_structdef) then
  556. begin
  557. { Don't test self and the vmt here. The reason is that }
  558. { a constructor already checks whether these are valid }
  559. { before. Further, in case of TThread the thread may }
  560. { free the class instance right after AfterConstruction }
  561. { has been called, so it may no longer be valid (JM) }
  562. oldlocalswitches:=current_settings.localswitches;
  563. current_settings.localswitches:=oldlocalswitches-[cs_check_object,cs_check_range];
  564. { a destructor needs a help procedure }
  565. if (current_procinfo.procdef.proctypeoption=potype_destructor) then
  566. begin
  567. if is_class(current_structdef) then
  568. begin
  569. srsym:=search_struct_member(current_structdef,'FREEINSTANCE');
  570. if assigned(srsym) and
  571. (srsym.typ=procsym) then
  572. begin
  573. { if self<>0 and vmt<>0 then freeinstance }
  574. addstatement(newstatement,cifnode.create(
  575. caddnode.create(andn,
  576. caddnode.create(unequaln,
  577. load_self_pointer_node,
  578. cnilnode.create),
  579. caddnode.create(unequaln,
  580. ctypeconvnode.create(
  581. load_vmt_pointer_node,
  582. voidpointertype),
  583. cpointerconstnode.create(0,voidpointertype))),
  584. ccallnode.create(nil,tprocsym(srsym),srsym.owner,load_self_node,[],nil),
  585. nil));
  586. end
  587. else
  588. internalerror(200305108);
  589. end
  590. else
  591. if is_object(current_structdef) then
  592. begin
  593. { finalize object data, but only if not in inherited call }
  594. if is_managed_type(current_structdef) then
  595. begin
  596. addstatement(newstatement,cifnode.create(
  597. caddnode.create(unequaln,
  598. ctypeconvnode.create_internal(load_vmt_pointer_node,voidpointertype),
  599. cnilnode.create),
  600. cnodeutils.finalize_data_node(load_self_node),
  601. nil));
  602. end;
  603. { parameter 3 : vmt_offset }
  604. { parameter 2 : pointer to vmt }
  605. { parameter 1 : self pointer }
  606. para:=ccallparanode.create(
  607. cordconstnode.create(tobjectdef(current_structdef).vmt_offset,s32inttype,false),
  608. ccallparanode.create(
  609. ctypeconvnode.create_internal(
  610. load_vmt_pointer_node,
  611. voidpointertype),
  612. ccallparanode.create(
  613. ctypeconvnode.create_internal(
  614. load_self_pointer_node,
  615. voidpointertype),
  616. nil)));
  617. addstatement(newstatement,
  618. ccallnode.createintern('fpc_help_destructor',para));
  619. end
  620. else if is_javaclass(current_structdef) then
  621. begin
  622. { nothing to do }
  623. end
  624. else
  625. internalerror(200305105);
  626. end;
  627. current_settings.localswitches:=oldlocalswitches;
  628. end;
  629. end;
  630. {****************************************************************************
  631. TCGProcInfo
  632. ****************************************************************************}
  633. destructor tcgprocinfo.destroy;
  634. begin
  635. code.free;
  636. inherited destroy;
  637. end;
  638. function tcgprocinfo.calc_stackframe_size:longint;
  639. begin
  640. result:=Align(tg.direction*tg.lasttemp,current_settings.alignment.localalignmin);
  641. end;
  642. procedure tcgprocinfo.printproc(pass:string);
  643. begin
  644. assign(printnodefile,treelogfilename);
  645. {$push}{$I-}
  646. append(printnodefile);
  647. if ioresult<>0 then
  648. rewrite(printnodefile);
  649. {$pop}
  650. if ioresult<>0 then
  651. begin
  652. Comment(V_Error,'Error creating '+treelogfilename);
  653. exit;
  654. end;
  655. writeln(printnodefile);
  656. writeln(printnodefile,'*******************************************************************************');
  657. writeln(printnodefile, pass);
  658. writeln(printnodefile,procdef.fullprocname(false));
  659. writeln(printnodefile,'*******************************************************************************');
  660. printnode(printnodefile,code);
  661. close(printnodefile);
  662. end;
  663. procedure tcgprocinfo.maybe_add_constructor_wrapper(var tocode: tnode; withexceptblock: boolean);
  664. var
  665. oldlocalswitches: tlocalswitches;
  666. srsym: tsym;
  667. constructionblock,
  668. exceptblock,
  669. newblock: tblocknode;
  670. newstatement: tstatementnode;
  671. pd: tprocdef;
  672. constructionsuccessful: tlocalvarsym;
  673. begin
  674. if assigned(procdef.struct) and
  675. (procdef.proctypeoption=potype_constructor) then
  676. begin
  677. withexceptblock:=
  678. withexceptblock and
  679. not(target_info.system in systems_garbage_collected_managed_types);
  680. { Don't test self and the vmt here. See generate_bodyexit_block }
  681. { why (JM) }
  682. oldlocalswitches:=current_settings.localswitches;
  683. current_settings.localswitches:=oldlocalswitches-[cs_check_object,cs_check_range];
  684. { call AfterConstruction for classes }
  685. constructionsuccessful:=nil;
  686. if is_class(procdef.struct) then
  687. begin
  688. constructionsuccessful:=clocalvarsym.create(internaltypeprefixName[itp_vmt_afterconstruction_local],vs_value,ptrsinttype,[],false);
  689. procdef.localst.insert(constructionsuccessful,false);
  690. srsym:=search_struct_member(procdef.struct,'AFTERCONSTRUCTION');
  691. if not assigned(srsym) or
  692. (srsym.typ<>procsym) then
  693. internalerror(200305106);
  694. current_filepos:=entrypos;
  695. constructionblock:=internalstatements(newstatement);
  696. { initialise constructionsuccessful with -1, indicating that
  697. the construction was not successful and hence
  698. beforedestruction should not be called if a destructor is
  699. called from the constructor }
  700. addstatement(newstatement,cassignmentnode.create(
  701. cloadnode.create(constructionsuccessful,procdef.localst),
  702. genintconstnode(-1))
  703. );
  704. { first execute all constructor code. If no exception
  705. occurred then we will execute afterconstruction,
  706. otherwise we won't (the exception will jump over us) }
  707. addstatement(newstatement,tocode);
  708. current_filepos:=exitpos;
  709. { if implicit finally node wasn't created, then exit label and
  710. finalization code must be handled here and placed before
  711. afterconstruction }
  712. if not ((pi_needs_implicit_finally in flags) and
  713. (cs_implicit_exceptions in current_settings.moduleswitches)) then
  714. begin
  715. include(tocode.flags,nf_block_with_exit);
  716. if procdef.proctypeoption<>potype_exceptfilter then
  717. addstatement(newstatement,cfinalizetempsnode.create);
  718. cnodeutils.procdef_block_add_implicit_finalize_nodes(procdef,newstatement);
  719. temps_finalized:=true;
  720. end;
  721. { construction successful -> beforedestruction should be called
  722. if an exception happens now }
  723. addstatement(newstatement,cassignmentnode.create(
  724. cloadnode.create(constructionsuccessful,procdef.localst),
  725. genintconstnode(1))
  726. );
  727. { Self can be nil when fail is called }
  728. { if self<>nil and vmt<>nil then afterconstruction }
  729. addstatement(newstatement,cifnode.create(
  730. caddnode.create(andn,
  731. caddnode.create(unequaln,
  732. load_self_node,
  733. cnilnode.create),
  734. caddnode.create(unequaln,
  735. load_vmt_pointer_node,
  736. cnilnode.create)),
  737. ccallnode.create(nil,tprocsym(srsym),srsym.owner,load_self_node,[],nil),
  738. nil));
  739. tocode:=constructionblock;
  740. end;
  741. if withexceptblock and (procdef.struct.typ=objectdef) then
  742. begin
  743. { Generate the implicit "fail" code for a constructor (destroy
  744. in case an exception happened) }
  745. pd:=tobjectdef(procdef.struct).find_destructor;
  746. { this will always be the case for classes, since tobject has
  747. a destructor }
  748. if assigned(pd) or is_object(procdef.struct) then
  749. begin
  750. current_filepos:=exitpos;
  751. exceptblock:=internalstatements(newstatement);
  752. { first free the instance if non-nil }
  753. if assigned(pd) then
  754. { if vmt<>0 then call destructor }
  755. addstatement(newstatement,
  756. cifnode.create(
  757. caddnode.create(unequaln,
  758. load_vmt_pointer_node,
  759. cnilnode.create),
  760. { cnf_create_failed -> don't call BeforeDestruction }
  761. ccallnode.create(nil,tprocsym(pd.procsym),pd.procsym.owner,load_self_node,[cnf_create_failed],nil),
  762. nil))
  763. else
  764. { object without destructor, call 'fail' helper }
  765. addstatement(newstatement,
  766. ccallnode.createintern('fpc_help_fail',
  767. ccallparanode.create(
  768. cordconstnode.create(tobjectdef(procdef.struct).vmt_offset,s32inttype,false),
  769. ccallparanode.create(
  770. ctypeconvnode.create_internal(
  771. load_vmt_pointer_node,
  772. voidpointertype),
  773. ccallparanode.create(
  774. ctypeconvnode.create_internal(
  775. load_self_pointer_node,
  776. voidpointertype),
  777. nil))))
  778. );
  779. { then re-raise the exception }
  780. addstatement(newstatement,craisenode.create(nil,nil,nil));
  781. current_filepos:=entrypos;
  782. newblock:=internalstatements(newstatement);
  783. { try
  784. tocode
  785. except
  786. exceptblock
  787. end
  788. }
  789. addstatement(newstatement,ctryexceptnode.create(
  790. tocode,
  791. nil,
  792. exceptblock));
  793. tocode:=newblock;
  794. end;
  795. end;
  796. current_settings.localswitches:=oldlocalswitches;
  797. end;
  798. end;
  799. procedure tcgprocinfo.add_entry_exit_code;
  800. var
  801. finalcode,
  802. bodyentrycode,
  803. bodyexitcode,
  804. wrappedbody,
  805. newblock : tnode;
  806. codestatement,
  807. newstatement : tstatementnode;
  808. oldfilepos : tfileposinfo;
  809. is_constructor: boolean;
  810. begin
  811. is_constructor:=assigned(procdef.struct) and
  812. (procdef.proctypeoption=potype_constructor);
  813. oldfilepos:=current_filepos;
  814. { Generate code/locations used at start of proc }
  815. current_filepos:=entrypos;
  816. entry_asmnode:=casmnode.create_get_position;
  817. loadpara_asmnode:=casmnode.create_get_position;
  818. stackcheck_asmnode:=casmnode.create_get_position;
  819. init_asmnode:=casmnode.create_get_position;
  820. bodyentrycode:=generate_bodyentry_block;
  821. { Generate code/locations used at end of proc }
  822. current_filepos:=exitpos;
  823. exitlabel_asmnode:=casmnode.create_get_position;
  824. temps_finalized:=false;
  825. bodyexitcode:=generate_bodyexit_block;
  826. { Generate procedure by combining init+body+final,
  827. depending on the implicit finally we need to add
  828. an try...finally...end wrapper }
  829. current_filepos:=entrypos;
  830. newblock:=internalstatements(newstatement);
  831. { initialization is common for all cases }
  832. addstatement(newstatement,loadpara_asmnode);
  833. addstatement(newstatement,stackcheck_asmnode);
  834. addstatement(newstatement,entry_asmnode);
  835. cnodeutils.procdef_block_add_implicit_initialize_nodes(procdef,newstatement);
  836. addstatement(newstatement,init_asmnode);
  837. if assigned(procdef.parentfpinitblock) then
  838. begin
  839. if assigned(tblocknode(procdef.parentfpinitblock).left) then
  840. begin
  841. { could be an asmn in case of a pure assembler procedure,
  842. but those shouldn't access nested variables }
  843. addstatement(newstatement,procdef.parentfpinitblock);
  844. end
  845. else
  846. procdef.parentfpinitblock.free;
  847. procdef.parentfpinitblock:=nil;
  848. end;
  849. addstatement(newstatement,bodyentrycode);
  850. if (cs_implicit_exceptions in current_settings.moduleswitches) and
  851. (pi_needs_implicit_finally in flags) and
  852. { but it's useless in init/final code of units }
  853. not(procdef.proctypeoption in [potype_unitfinalize,potype_unitinit]) and
  854. not(target_info.system in systems_garbage_collected_managed_types) then
  855. begin
  856. { Any result of managed type must be returned in parameter }
  857. if is_managed_type(procdef.returndef) and
  858. (not paramanager.ret_in_param(procdef.returndef,procdef)) and
  859. (not is_class(procdef.returndef)) then
  860. InternalError(2013121301);
  861. { Generate special exception block only needed when
  862. implicit finaly is used }
  863. current_filepos:=exitpos;
  864. { Generate code that will be in the try...finally }
  865. finalcode:=internalstatements(codestatement);
  866. if procdef.proctypeoption<>potype_exceptfilter then
  867. addstatement(codestatement,cfinalizetempsnode.create);
  868. cnodeutils.procdef_block_add_implicit_finalize_nodes(procdef,codestatement);
  869. temps_finalized:=true;
  870. current_filepos:=entrypos;
  871. wrappedbody:=ctryfinallynode.create_implicit(code,finalcode);
  872. { afterconstruction must be called after finalizetemps, because it
  873. has to execute after the temps have been finalised in case of a
  874. refcounted class (afterconstruction decreases the refcount
  875. without freeing the instance if the count becomes nil, while
  876. the finalising of the temps can free the instance) }
  877. maybe_add_constructor_wrapper(wrappedbody,true);
  878. addstatement(newstatement,wrappedbody);
  879. addstatement(newstatement,exitlabel_asmnode);
  880. addstatement(newstatement,bodyexitcode);
  881. { set flag the implicit finally has been generated }
  882. include(flags,pi_has_implicit_finally);
  883. end
  884. else
  885. begin
  886. { constructors need destroy-on-exception code even if they don't
  887. have managed variables/temps }
  888. maybe_add_constructor_wrapper(code,
  889. cs_implicit_exceptions in current_settings.moduleswitches);
  890. current_filepos:=entrypos;
  891. addstatement(newstatement,code);
  892. current_filepos:=exitpos;
  893. if assigned(nestedexitlabel) then
  894. addstatement(newstatement,clabelnode.create(cnothingnode.create,nestedexitlabel));
  895. addstatement(newstatement,exitlabel_asmnode);
  896. addstatement(newstatement,bodyexitcode);
  897. if not is_constructor then
  898. begin
  899. if procdef.proctypeoption<>potype_exceptfilter then
  900. addstatement(newstatement,cfinalizetempsnode.create);
  901. cnodeutils.procdef_block_add_implicit_finalize_nodes(procdef,newstatement);
  902. temps_finalized:=true;
  903. end;
  904. end;
  905. if not temps_finalized then
  906. begin
  907. current_filepos:=exitpos;
  908. cnodeutils.procdef_block_add_implicit_finalize_nodes(procdef,newstatement);
  909. end;
  910. do_firstpass(newblock);
  911. code:=newblock;
  912. current_filepos:=oldfilepos;
  913. end;
  914. procedure clearrefs(p:TObject;arg:pointer);
  915. begin
  916. if (tsym(p).typ in [localvarsym,paravarsym,staticvarsym]) then
  917. if tabstractvarsym(p).refs>1 then
  918. tabstractvarsym(p).refs:=1;
  919. end;
  920. procedure translate_registers(p:TObject;list:pointer);
  921. begin
  922. if (tsym(p).typ in [localvarsym,paravarsym,staticvarsym]) and
  923. (tabstractnormalvarsym(p).localloc.loc in [LOC_REGISTER,LOC_CREGISTER,LOC_MMREGISTER,
  924. LOC_CMMREGISTER,LOC_FPUREGISTER,LOC_CFPUREGISTER]) then
  925. begin
  926. if not(cs_no_regalloc in current_settings.globalswitches) then
  927. begin
  928. cg.translate_register(tabstractnormalvarsym(p).localloc.register);
  929. if (tabstractnormalvarsym(p).localloc.registerhi<>NR_NO) then
  930. cg.translate_register(tabstractnormalvarsym(p).localloc.registerhi);
  931. end;
  932. end;
  933. end;
  934. {$if defined(i386) or defined(x86_64) or defined(arm) or defined(riscv32) or defined(riscv64)}
  935. const
  936. exception_flags: array[boolean] of tprocinfoflags = (
  937. [],
  938. [pi_uses_exceptions,pi_needs_implicit_finally,pi_has_implicit_finally]
  939. );
  940. {$endif}
  941. procedure tcgprocinfo.setup_tempgen;
  942. begin
  943. tg:=tgobjclass.create;
  944. {$if defined(i386) or defined(x86_64) or defined(arm)}
  945. {$if defined(arm)}
  946. { frame and stack pointer must be always the same on arm thumb so it makes no
  947. sense to fiddle with a frame pointer }
  948. if GenerateThumbCode then
  949. begin
  950. framepointer:=NR_STACK_POINTER_REG;
  951. tg.direction:=1;
  952. end
  953. else
  954. {$endif defined(arm)}
  955. begin
  956. { try to strip the stack frame }
  957. { set the framepointer to esp if:
  958. - no assembler directive, those are handled in assembler_block
  959. in pstatment.pas (for cases not caught by the Delphi
  960. exception below)
  961. - no exceptions are used
  962. - no pushes are used/esp modifications, could be:
  963. * outgoing parameters on the stack on non-fixed stack target
  964. * incoming parameters on the stack
  965. * open arrays
  966. - no inline assembler
  967. or
  968. - Delphi mode
  969. - assembler directive
  970. - no pushes are used/esp modifications, could be:
  971. * outgoing parameters on the stack
  972. * incoming parameters on the stack
  973. * open arrays
  974. - no local variables
  975. - stack frame cannot be optimized if using Win64 SEH
  976. (at least with the current state of our codegenerator).
  977. }
  978. if ((po_assembler in procdef.procoptions) and
  979. (m_delphi in current_settings.modeswitches) and
  980. { localst at main_program_level is a staticsymtable }
  981. (procdef.localst.symtablelevel<>main_program_level) and
  982. (tabstractlocalsymtable(procdef.localst).count_locals = 0)) or
  983. ((cs_opt_stackframe in current_settings.optimizerswitches) and
  984. not(cs_generate_stackframes in current_settings.localswitches) and
  985. not(cs_profile in current_settings.moduleswitches) and
  986. not(po_assembler in procdef.procoptions) and
  987. not ((pi_has_stackparameter in flags)
  988. {$ifndef arm} { Outgoing parameter(s) on stack do not need stackframe on x86 targets
  989. with fixed stack. On ARM it fails, see bug #25050 }
  990. and (not paramanager.use_fixed_stack)
  991. {$endif arm}
  992. ) and
  993. ((flags*([pi_has_assembler_block,pi_is_assembler,
  994. pi_needs_stackframe]+
  995. exception_flags[(target_info.cpu=cpu_i386)
  996. {$ifndef DISABLE_WIN64_SEH}
  997. or (target_info.system=system_x86_64_win64)
  998. {$endif DISABLE_WIN64_SEH}
  999. ]))=[])
  1000. )
  1001. then
  1002. begin
  1003. { we need the parameter info here to determine if the procedure gets
  1004. parameters on the stack
  1005. calling generate_parameter_info doesn't hurt but it costs time
  1006. (necessary to init para_stack_size)
  1007. }
  1008. generate_parameter_info;
  1009. if not(procdef.stack_tainting_parameter(calleeside)) and
  1010. not(has_assembler_child) and (para_stack_size=0) then
  1011. begin
  1012. { Only need to set the framepointer }
  1013. framepointer:=NR_STACK_POINTER_REG;
  1014. tg.direction:=1;
  1015. end
  1016. {$if defined(arm)}
  1017. { On arm, the stack frame size can be estimated to avoid using an extra frame pointer,
  1018. in case parameters are passed on the stack.
  1019. However, the draw back is, if the estimation fails, compilation will break later on
  1020. with an internal error, so this switch is not enabled by default yet. To overcome this,
  1021. multipass compilation of subroutines must be supported
  1022. }
  1023. else if (cs_opt_forcenostackframe in current_settings.optimizerswitches) and
  1024. not(has_assembler_child) then
  1025. begin
  1026. { Only need to set the framepointer }
  1027. framepointer:=NR_STACK_POINTER_REG;
  1028. tg.direction:=1;
  1029. include(flags,pi_estimatestacksize);
  1030. set_first_temp_offset;
  1031. procdef.has_paraloc_info:=callnoside;
  1032. generate_parameter_info;
  1033. exit;
  1034. end;
  1035. {$endif defined(arm)}
  1036. end;
  1037. end;
  1038. {$endif defined(x86) or defined(arm)}
  1039. { set the start offset to the start of the temp area in the stack }
  1040. set_first_temp_offset;
  1041. end;
  1042. function tcgprocinfo.has_assembler_child : boolean;
  1043. var
  1044. hp : tprocinfo;
  1045. begin
  1046. result:=false;
  1047. hp:=get_first_nestedproc;
  1048. while assigned(hp) do
  1049. begin
  1050. if (hp.flags*[pi_has_assembler_block,pi_is_assembler])<>[] then
  1051. begin
  1052. result:=true;
  1053. exit;
  1054. end;
  1055. hp:=tprocinfo(hp.next);
  1056. end;
  1057. end;
  1058. procedure tcgprocinfo.set_eh_info;
  1059. begin
  1060. inherited;
  1061. if (tf_use_psabieh in target_info.flags) and
  1062. ((pi_uses_exceptions in flags) or
  1063. ((cs_implicit_exceptions in current_settings.moduleswitches) and
  1064. (pi_needs_implicit_finally in flags))) or
  1065. (pi_has_except_table_data in flags) then
  1066. procdef.personality:=search_system_proc('_FPC_PSABIEH_PERSONALITY_V0');
  1067. end;
  1068. procedure tcgprocinfo.generate_code_tree;
  1069. var
  1070. hpi : tcgprocinfo;
  1071. begin
  1072. { generate code for this procedure }
  1073. generate_code;
  1074. { process nested procedures }
  1075. hpi:=tcgprocinfo(get_first_nestedproc);
  1076. while assigned(hpi) do
  1077. begin
  1078. hpi.generate_code_tree;
  1079. hpi:=tcgprocinfo(hpi.next);
  1080. end;
  1081. resetprocdef;
  1082. end;
  1083. { For SEH, the code from 'finally' blocks must be put into a separate procedures,
  1084. which can be called by OS during stack unwind. This resembles nested procedures,
  1085. but finalizer procedures do not have their own local variables and work directly
  1086. with the stack frame of parent. In particular, the tempgen must be shared, so
  1087. 1) finalizer procedure is able to finalize temps of the parent,
  1088. 2) if the finalizer procedure is complex enough to need its own temps, they are
  1089. allocated in stack frame of parent, so second-level finalizer procedures are
  1090. not needed.
  1091. Due to requirement of shared tempgen we cannot process finalizer as a regular nested
  1092. procedure (after the parent) and have to do it inline.
  1093. This is called by platform-specific tryfinallynodes during pass2.
  1094. Here we put away the codegen (which carries the register allocator state), process
  1095. the 'nested' procedure, then restore previous cg and continue processing the parent
  1096. procedure. generate_code() will create another cg, but not another tempgen because
  1097. setup_tempgen() is not called for potype_exceptfilter procedures. }
  1098. procedure tcgprocinfo.generate_exceptfilter(nestedpi: tcgprocinfo);
  1099. var
  1100. saved_cg: tcg;
  1101. saved_hlcg: thlcgobj;
  1102. {$ifdef cpu64bitalu}
  1103. saved_cg128 : tcg128;
  1104. {$else cpu64bitalu}
  1105. saved_cg64 : tcg64;
  1106. {$endif cpu64bitalu}
  1107. begin
  1108. if nestedpi.procdef.proctypeoption<>potype_exceptfilter then
  1109. InternalError(201201141);
  1110. { flush code generated this far }
  1111. aktproccode.concatlist(current_asmdata.CurrAsmList);
  1112. { save the codegen }
  1113. saved_cg:=cg;
  1114. saved_hlcg:=hlcg;
  1115. cg:=nil;
  1116. hlcg:=nil;
  1117. {$ifdef cpu64bitalu}
  1118. saved_cg128:=cg128;
  1119. cg128:=nil;
  1120. {$else cpu64bitalu}
  1121. saved_cg64:=cg64;
  1122. cg64:=nil;
  1123. {$endif cpu64bitalu}
  1124. nestedpi.generate_code;
  1125. { prevents generating code the second time when processing nested procedures }
  1126. nestedpi.resetprocdef;
  1127. cg:=saved_cg;
  1128. hlcg:=saved_hlcg;
  1129. {$ifdef cpu64bitalu}
  1130. cg128:=saved_cg128;
  1131. {$else cpu64bitalu}
  1132. cg64:=saved_cg64;
  1133. {$endif cpu64bitalu}
  1134. add_reg_instruction_hook:[email protected]_reg_instruction;
  1135. end;
  1136. procedure TCGProcinfo.CreateInlineInfo;
  1137. begin
  1138. new(procdef.inlininginfo);
  1139. procdef.inlininginfo^.code:=code.getcopy;
  1140. procdef.inlininginfo^.flags:=flags;
  1141. { The blocknode needs to set an exit label }
  1142. if procdef.inlininginfo^.code.nodetype=blockn then
  1143. include(procdef.inlininginfo^.code.flags,nf_block_with_exit);
  1144. procdef.has_inlininginfo:=true;
  1145. end;
  1146. procedure searchthreadvar(p: TObject; arg: pointer);
  1147. var
  1148. i : longint;
  1149. pd : tprocdef;
  1150. begin
  1151. case tsym(p).typ of
  1152. staticvarsym :
  1153. begin
  1154. { local (procedure or unit) variables only need finalization
  1155. if they are used
  1156. }
  1157. if (vo_is_thread_var in tstaticvarsym(p).varoptions) and
  1158. ((tstaticvarsym(p).refs>0) or
  1159. { global (unit) variables always need finalization, since
  1160. they may also be used in another unit
  1161. }
  1162. (tstaticvarsym(p).owner.symtabletype=globalsymtable)) and
  1163. (
  1164. (tstaticvarsym(p).varspez<>vs_const) or
  1165. (vo_force_finalize in tstaticvarsym(p).varoptions)
  1166. ) and
  1167. not(vo_is_funcret in tstaticvarsym(p).varoptions) and
  1168. not(vo_is_external in tstaticvarsym(p).varoptions) and
  1169. is_managed_type(tstaticvarsym(p).vardef) then
  1170. include(current_procinfo.flags,pi_uses_threadvar);
  1171. end;
  1172. procsym :
  1173. begin
  1174. for i:=0 to tprocsym(p).ProcdefList.Count-1 do
  1175. begin
  1176. pd:=tprocdef(tprocsym(p).ProcdefList[i]);
  1177. if assigned(pd.localst) and
  1178. (pd.procsym=tprocsym(p)) and
  1179. (pd.localst.symtabletype<>staticsymtable) then
  1180. pd.localst.SymList.ForEachCall(@searchthreadvar,arg);
  1181. end;
  1182. end;
  1183. end;
  1184. end;
  1185. function searchusercode(var n: tnode; arg: pointer): foreachnoderesult;
  1186. begin
  1187. if nf_usercode_entry in n.flags then
  1188. begin
  1189. pnode(arg)^:=n;
  1190. result:=fen_norecurse_true
  1191. end
  1192. else
  1193. result:=fen_false;
  1194. end;
  1195. function TCGProcinfo.GetUserCode : tnode;
  1196. var
  1197. n : tnode;
  1198. begin
  1199. n:=nil;
  1200. foreachnodestatic(code,@searchusercode,@n);
  1201. if not(assigned(n)) then
  1202. internalerror(2013111004);
  1203. result:=n;
  1204. end;
  1205. procedure tcgprocinfo.generate_code;
  1206. procedure check_for_threadvars_in_initfinal;
  1207. begin
  1208. if current_procinfo.procdef.proctypeoption=potype_unitfinalize then
  1209. begin
  1210. { this is also used for initialization of variables in a
  1211. program which does not have a globalsymtable }
  1212. if assigned(current_module.globalsymtable) then
  1213. TSymtable(current_module.globalsymtable).SymList.ForEachCall(@searchthreadvar,nil);
  1214. TSymtable(current_module.localsymtable).SymList.ForEachCall(@searchthreadvar,nil);
  1215. end;
  1216. end;
  1217. var
  1218. old_current_procinfo : tprocinfo;
  1219. oldmaxfpuregisters : longint;
  1220. oldfilepos : tfileposinfo;
  1221. old_current_structdef : tabstractrecorddef;
  1222. templist : TAsmList;
  1223. headertai : tai;
  1224. i : integer;
  1225. {RedoDFA : boolean;}
  1226. procedure delete_marker(anode: tasmnode);
  1227. var
  1228. ai: tai;
  1229. begin
  1230. if assigned(anode) then
  1231. begin
  1232. ai:=anode.currenttai;
  1233. if assigned(ai) then
  1234. begin
  1235. aktproccode.remove(ai);
  1236. ai.free;
  1237. anode.currenttai:=nil;
  1238. end;
  1239. end;
  1240. end;
  1241. begin
  1242. { the initialization procedure can be empty, then we
  1243. don't need to generate anything. When it was an empty
  1244. procedure there would be at least a blocknode }
  1245. if not assigned(code) then
  1246. exit;
  1247. { We need valid code }
  1248. if Errorcount<>0 then
  1249. exit;
  1250. { No code can be generated for generic template }
  1251. if (df_generic in procdef.defoptions) then
  1252. internalerror(200511152);
  1253. { For regular procedures the RA and Tempgen shall not be available yet,
  1254. but exception filters reuse Tempgen of parent }
  1255. if assigned(tg)<>(procdef.proctypeoption=potype_exceptfilter) then
  1256. internalerror(200309201);
  1257. old_current_procinfo:=current_procinfo;
  1258. oldfilepos:=current_filepos;
  1259. old_current_structdef:=current_structdef;
  1260. oldmaxfpuregisters:=current_settings.maxfpuregisters;
  1261. current_procinfo:=self;
  1262. current_filepos:=entrypos;
  1263. current_structdef:=procdef.struct;
  1264. { store start of user code, it must be a block node, it will be used later one to
  1265. check variable lifeness }
  1266. include(code.flags,nf_usercode_entry);
  1267. { add wrapping code if necessary (initialization of typed constants on
  1268. some platforms, initing of local variables and out parameters with
  1269. trashing values, ...) }
  1270. { init/final code must be wrapped later (after code for main proc body
  1271. has been generated) }
  1272. if not(current_procinfo.procdef.proctypeoption in [potype_unitinit,potype_unitfinalize]) then
  1273. code:=cnodeutils.wrap_proc_body(procdef,code);
  1274. { automatic inlining? }
  1275. if (cs_opt_autoinline in current_settings.optimizerswitches) and
  1276. { inlining not turned off? }
  1277. (cs_do_inline in current_settings.localswitches) and
  1278. not(po_noinline in procdef.procoptions) and
  1279. { no inlining yet? }
  1280. not(procdef.has_inlininginfo) and not(has_nestedprocs) and
  1281. not(procdef.proctypeoption in [potype_proginit,potype_unitinit,potype_unitfinalize,potype_constructor,
  1282. potype_destructor,potype_class_constructor,potype_class_destructor]) and
  1283. ((procdef.procoptions*[po_exports,po_external,po_interrupt,po_virtualmethod,po_iocheck])=[]) and
  1284. (not(procdef.proccalloption in [pocall_safecall])) and
  1285. { rough approximation if we should auto inline }
  1286. (node_count(code)<=10) then
  1287. begin
  1288. { Can we inline this procedure? }
  1289. if checknodeinlining(procdef) then
  1290. begin
  1291. Message1(cg_d_autoinlining,procdef.GetTypeName);
  1292. include(procdef.procoptions,po_inline);
  1293. CreateInlineInfo;
  1294. end;
  1295. end;
  1296. templist:=TAsmList.create;
  1297. { add parast/localst to symtablestack }
  1298. add_to_symtablestack;
  1299. { clear register count }
  1300. procdef.localst.SymList.ForEachCall(@clearrefs,nil);
  1301. procdef.parast.SymList.ForEachCall(@clearrefs,nil);
  1302. { there's always a call to FPC_INITIALIZEUNITS/FPC_DO_EXIT in the main program }
  1303. if (procdef.localst.symtablelevel=main_program_level) and
  1304. (not current_module.is_unit) then
  1305. begin
  1306. include(flags,pi_do_call);
  1307. { the main program never returns due to the do_exit call }
  1308. if not(current_module.islibrary) and (procdef.proctypeoption=potype_proginit) then
  1309. include(procdef.procoptions,po_noreturn);
  1310. end;
  1311. { set implicit_finally flag when there are locals/paras to be finalized }
  1312. if not(po_assembler in current_procinfo.procdef.procoptions) then
  1313. begin
  1314. procdef.parast.SymList.ForEachCall(@check_finalize_paras,nil);
  1315. procdef.localst.SymList.ForEachCall(@check_finalize_locals,nil);
  1316. end;
  1317. {$ifdef SUPPORT_SAFECALL}
  1318. { set implicit_finally flag for if procedure is safecall }
  1319. if (tf_safecall_exceptions in target_info.flags) and
  1320. (procdef.proccalloption=pocall_safecall) then
  1321. include(flags, pi_needs_implicit_finally);
  1322. {$endif}
  1323. { firstpass everything }
  1324. flowcontrol:=[];
  1325. do_firstpass(code);
  1326. {$if defined(i386) or defined(i8086)}
  1327. if node_resources_fpu(code)>0 then
  1328. include(flags,pi_uses_fpu);
  1329. {$endif i386 or i8086}
  1330. { Print the node to tree.log }
  1331. if paraprintnodetree=1 then
  1332. printproc( 'after the firstpass');
  1333. { do this before adding the entry code else the tail recursion recognition won't work,
  1334. if this causes troubles, it must be if'ed
  1335. }
  1336. if (cs_opt_tailrecursion in current_settings.optimizerswitches) and
  1337. (pi_is_recursive in flags) then
  1338. do_opttail(code,procdef);
  1339. if cs_opt_constant_propagate in current_settings.optimizerswitches then
  1340. do_optconstpropagate(code);
  1341. if (cs_opt_nodedfa in current_settings.optimizerswitches) and
  1342. { creating dfa is not always possible }
  1343. ((flags*[pi_has_assembler_block,pi_uses_exceptions,pi_is_assembler])=[]) then
  1344. begin
  1345. dfabuilder:=TDFABuilder.Create;
  1346. dfabuilder.createdfainfo(code);
  1347. include(flags,pi_dfaavailable);
  1348. { when life info is available, we can give more sophisticated warning about uninitialized
  1349. variables ...
  1350. ... but not for the finalization section of a unit, we would need global dfa to handle
  1351. it properly }
  1352. if potype_unitfinalize<>procdef.proctypeoption then
  1353. { iterate through life info of the first node }
  1354. for i:=0 to dfabuilder.nodemap.count-1 do
  1355. begin
  1356. if DFASetIn(GetUserCode.optinfo^.life,i) then
  1357. begin
  1358. { do not warn for certain parameters: }
  1359. if not((tnode(dfabuilder.nodemap[i]).nodetype=loadn) and (tloadnode(dfabuilder.nodemap[i]).symtableentry.typ=paravarsym) and
  1360. { do not warn about parameters passed by var }
  1361. (((tparavarsym(tloadnode(dfabuilder.nodemap[i]).symtableentry).varspez=vs_var) and
  1362. { function result is passed by var but it must be initialized }
  1363. not(vo_is_funcret in tparavarsym(tloadnode(dfabuilder.nodemap[i]).symtableentry).varoptions)) or
  1364. { do not warn about initialized hidden parameters }
  1365. ((tparavarsym(tloadnode(dfabuilder.nodemap[i]).symtableentry).varoptions*[vo_is_high_para,vo_is_parentfp,vo_is_result,vo_is_self])<>[]))) then
  1366. CheckAndWarn(GetUserCode,tnode(dfabuilder.nodemap[i]));
  1367. end
  1368. else
  1369. begin
  1370. if (tnode(dfabuilder.nodemap[i]).nodetype=loadn) and
  1371. (tloadnode(dfabuilder.nodemap[i]).symtableentry.typ in [staticvarsym,localvarsym]) then
  1372. tabstractnormalvarsym(tloadnode(dfabuilder.nodemap[i]).symtableentry).noregvarinitneeded:=true
  1373. end;
  1374. end;
  1375. end;
  1376. if (pi_dfaavailable in flags) and (cs_opt_dead_store_eliminate in current_settings.optimizerswitches) then
  1377. do_optdeadstoreelim(code);
  1378. if (cs_opt_loopstrength in current_settings.optimizerswitches)
  1379. { our induction variable strength reduction doesn't like
  1380. for loops with more than one entry }
  1381. and not(pi_has_label in flags) then
  1382. begin
  1383. {RedoDFA:=}OptimizeInductionVariables(code);
  1384. end;
  1385. if (cs_opt_remove_emtpy_proc in current_settings.optimizerswitches) and
  1386. (procdef.proctypeoption in [potype_operator,potype_procedure,potype_function]) and
  1387. (code.nodetype=blockn) and (tblocknode(code).statements=nil) then
  1388. procdef.isempty:=true;
  1389. { unit static/global symtables might contain threadvars which are not explicitly used but which might
  1390. require a tls register, so check for such variables }
  1391. check_for_threadvars_in_initfinal;
  1392. { add implicit entry and exit code }
  1393. add_entry_exit_code;
  1394. if cs_opt_nodecse in current_settings.optimizerswitches then
  1395. do_optcse(code);
  1396. if cs_opt_use_load_modify_store in current_settings.optimizerswitches then
  1397. do_optloadmodifystore(code);
  1398. { only do secondpass if there are no errors }
  1399. if (ErrorCount=0) then
  1400. begin
  1401. create_hlcodegen;
  1402. setup_eh;
  1403. if (procdef.proctypeoption<>potype_exceptfilter) then
  1404. setup_tempgen;
  1405. { Create register allocator, must come after framepointer is known }
  1406. hlcg.init_register_allocators;
  1407. generate_parameter_info;
  1408. { allocate got register if needed }
  1409. allocate_got_register(aktproccode);
  1410. if pi_uses_threadvar in flags then
  1411. allocate_tls_register(aktproccode);
  1412. { Allocate space in temp/registers for parast and localst }
  1413. current_filepos:=entrypos;
  1414. gen_alloc_symtable(aktproccode,procdef,procdef.parast);
  1415. gen_alloc_symtable(aktproccode,procdef,procdef.localst);
  1416. { Store temp offset for information about 'real' temps }
  1417. tempstart:=tg.lasttemp;
  1418. { Generate code to load register parameters in temps and insert local
  1419. copies for values parameters. This must be done before the code for the
  1420. body is generated because the localloc is updated.
  1421. Note: The generated code will be inserted after the code generation of
  1422. the body is finished, because only then the position is known }
  1423. {$ifdef oldregvars}
  1424. assign_regvars(code);
  1425. {$endif oldreg}
  1426. current_filepos:=entrypos;
  1427. hlcg.gen_load_para_value(templist);
  1428. { caller paraloc info is also necessary in the stackframe_entry
  1429. code of the ppc (and possibly other processors) }
  1430. procdef.init_paraloc_info(callerside);
  1431. CalcExecutionWeights(code);
  1432. { Print the node to tree.log }
  1433. if paraprintnodetree=1 then
  1434. printproc( 'right before code generation');
  1435. { generate code for the node tree }
  1436. do_secondpass(code);
  1437. aktproccode.concatlist(current_asmdata.CurrAsmList);
  1438. { The position of the loadpara_asmnode is now known }
  1439. aktproccode.insertlistafter(loadpara_asmnode.currenttai,templist);
  1440. { first generate entry and initialize code with the correct
  1441. position and switches }
  1442. current_filepos:=entrypos;
  1443. current_settings.localswitches:=entryswitches;
  1444. cg.set_regalloc_live_range_direction(rad_backwards);
  1445. hlcg.gen_entry_code(templist);
  1446. aktproccode.insertlistafter(entry_asmnode.currenttai,templist);
  1447. hlcg.gen_initialize_code(templist);
  1448. aktproccode.insertlistafter(init_asmnode.currenttai,templist);
  1449. { now generate finalize and exit code with the correct position
  1450. and switches }
  1451. current_filepos:=exitpos;
  1452. current_settings.localswitches:=exitswitches;
  1453. cg.set_regalloc_live_range_direction(rad_forward);
  1454. if assigned(finalize_procinfo) then
  1455. generate_exceptfilter(tcgprocinfo(finalize_procinfo))
  1456. else if not temps_finalized then
  1457. begin
  1458. hlcg.gen_finalize_code(templist);
  1459. { the finalcode must be concated if there was no position available,
  1460. using insertlistafter will result in an insert at the start
  1461. when currentai=nil }
  1462. aktproccode.concatlist(templist);
  1463. end;
  1464. { insert exit label at the correct position }
  1465. hlcg.a_label(templist,CurrExitLabel);
  1466. if assigned(exitlabel_asmnode.currenttai) then
  1467. aktproccode.insertlistafter(exitlabel_asmnode.currenttai,templist)
  1468. else
  1469. aktproccode.concatlist(templist);
  1470. { exit code }
  1471. hlcg.gen_exit_code(templist);
  1472. aktproccode.concatlist(templist);
  1473. {$ifdef OLDREGVARS}
  1474. { note: this must be done only after as much code as possible has }
  1475. { been generated. The result is that when you ungetregister() a }
  1476. { regvar, it will actually free the regvar (and alse free the }
  1477. { the regvars at the same time). Doing this too early will }
  1478. { confuse the register allocator, as the regvars will still be }
  1479. { used. It should be done before loading the result regs (so }
  1480. { they don't conflict with the regvars) and before }
  1481. { gen_entry_code (that one has to be able to allocate the }
  1482. { regvars again) (JM) }
  1483. free_regvars(aktproccode);
  1484. {$endif OLDREGVARS}
  1485. { generate symbol and save end of header position }
  1486. current_filepos:=entrypos;
  1487. hlcg.gen_proc_symbol(templist);
  1488. headertai:=tai(templist.last);
  1489. { insert symbol }
  1490. aktproccode.insertlist(templist);
  1491. { Free space in temp/registers for parast and localst, must be
  1492. done after gen_entry_code }
  1493. current_filepos:=exitpos;
  1494. { make sure the got/pic register doesn't get freed in the }
  1495. { middle of a loop }
  1496. if (cs_create_pic in current_settings.moduleswitches) and
  1497. (pi_needs_got in flags) and
  1498. (got<>NR_NO) then
  1499. cg.a_reg_sync(aktproccode,got);
  1500. if (pi_uses_threadvar in flags) and
  1501. (tlsoffset<>NR_NO) then
  1502. cg.a_reg_sync(aktproccode,tlsoffset);
  1503. gen_free_symtable(aktproccode,procdef.localst);
  1504. gen_free_symtable(aktproccode,procdef.parast);
  1505. { add code that will load the return value, this is not done
  1506. for assembler routines when they didn't reference the result
  1507. variable }
  1508. hlcg.gen_load_return_value(templist);
  1509. aktproccode.concatlist(templist);
  1510. { Already reserve all registers for stack checking code and
  1511. generate the call to the helper function }
  1512. if not(tf_no_generic_stackcheck in target_info.flags) and
  1513. (cs_check_stack in entryswitches) and
  1514. not(po_assembler in procdef.procoptions) and
  1515. (procdef.proctypeoption<>potype_proginit) then
  1516. begin
  1517. current_filepos:=entrypos;
  1518. hlcg.gen_stack_check_call(templist);
  1519. aktproccode.insertlistafter(stackcheck_asmnode.currenttai,templist);
  1520. end;
  1521. { this code (got loading) comes before everything which has }
  1522. { already been generated, so reset the info about already }
  1523. { backwards extended registers (so their live range can be }
  1524. { extended backwards even further if needed) }
  1525. { This code must be }
  1526. { a) generated after do_secondpass has been called }
  1527. { (because pi_needs_got may be set there) }
  1528. { b) generated before register allocation, because the }
  1529. { got/pic register can be a virtual one }
  1530. { c) inserted before the entry code, because the entry }
  1531. { code may need global symbols such as init rtti }
  1532. { d) inserted after the stackframe allocation, because }
  1533. { this register may have to be spilled }
  1534. cg.set_regalloc_live_range_direction(rad_backwards_reinit);
  1535. current_filepos:=entrypos;
  1536. { load got if necessary }
  1537. cg.g_maybe_got_init(templist);
  1538. aktproccode.insertlistafter(headertai,templist);
  1539. if (pi_uses_threadvar in flags) and (tf_section_threadvars in target_info.flags) then
  1540. cg.g_maybe_tls_init(templist);
  1541. aktproccode.insertlistafter(stackcheck_asmnode.currenttai,templist);
  1542. { re-enable if more code at the end is ever generated here
  1543. cg.set_regalloc_live_range_direction(rad_forward);
  1544. }
  1545. {$ifndef NoOpt}
  1546. {$ifndef i386}
  1547. if (cs_opt_scheduler in current_settings.optimizerswitches) and
  1548. { do not optimize pure assembler procedures }
  1549. not(pi_is_assembler in flags) then
  1550. preregallocschedule(aktproccode);
  1551. {$endif i386}
  1552. {$endif NoOpt}
  1553. { The procedure body is finished, we can now
  1554. allocate the registers }
  1555. cg.do_register_allocation(aktproccode,headertai);
  1556. { translate imag. register to their real counter parts
  1557. this is necessary for debuginfo and verbose assembler output
  1558. when SSA will be implented, this will be more complicated because we've to
  1559. maintain location lists }
  1560. procdef.parast.SymList.ForEachCall(@translate_registers,templist);
  1561. procdef.localst.SymList.ForEachCall(@translate_registers,templist);
  1562. if (cs_create_pic in current_settings.moduleswitches) and
  1563. (pi_needs_got in flags) and
  1564. not(cs_no_regalloc in current_settings.globalswitches) and
  1565. (got<>NR_NO) then
  1566. cg.translate_register(got);
  1567. { Add save and restore of used registers }
  1568. current_filepos:=entrypos;
  1569. gen_save_used_regs(templist);
  1570. { Remember the last instruction of register saving block
  1571. (may be =nil for e.g. assembler procedures) }
  1572. endprologue_ai:=templist.last;
  1573. aktproccode.insertlistafter(headertai,templist);
  1574. current_filepos:=exitpos;
  1575. gen_restore_used_regs(aktproccode);
  1576. { We know the size of the stack, now we can generate the
  1577. parameter that is passed to the stack checking code }
  1578. if not(tf_no_generic_stackcheck in target_info.flags) and
  1579. (cs_check_stack in entryswitches) and
  1580. not(po_assembler in procdef.procoptions) and
  1581. (procdef.proctypeoption<>potype_proginit) then
  1582. begin
  1583. current_filepos:=entrypos;
  1584. hlcg.gen_stack_check_size_para(templist);
  1585. aktproccode.insertlistafter(stackcheck_asmnode.currenttai,templist)
  1586. end;
  1587. current_procinfo.set_eh_info;
  1588. { Add entry code (stack allocation) after header }
  1589. current_filepos:=entrypos;
  1590. gen_proc_entry_code(templist);
  1591. aktproccode.insertlistafter(headertai,templist);
  1592. {$ifdef SUPPORT_SAFECALL}
  1593. { Set return value of safecall procedure if implicit try/finally blocks are disabled }
  1594. if not (cs_implicit_exceptions in current_settings.moduleswitches) and
  1595. (tf_safecall_exceptions in target_info.flags) and
  1596. (procdef.proccalloption=pocall_safecall) then
  1597. cg.a_load_const_reg(aktproccode,OS_ADDR,0,NR_FUNCTION_RETURN_REG);
  1598. {$endif}
  1599. { Add exit code at the end }
  1600. current_filepos:=exitpos;
  1601. gen_proc_exit_code(templist);
  1602. aktproccode.concatlist(templist);
  1603. { check if the implicit finally has been generated. The flag
  1604. should already be set in pass1 }
  1605. if (cs_implicit_exceptions in current_settings.moduleswitches) and
  1606. not(procdef.proctypeoption in [potype_unitfinalize,potype_unitinit]) and
  1607. (pi_needs_implicit_finally in flags) and
  1608. not(pi_has_implicit_finally in flags) and
  1609. not(target_info.system in systems_garbage_collected_managed_types) then
  1610. internalerror(200405231);
  1611. { sanity check }
  1612. if not(assigned(current_procinfo.procdef.personality)) and
  1613. (tf_use_psabieh in target_info.flags) and
  1614. ((pi_uses_exceptions in flags) or
  1615. ((cs_implicit_exceptions in current_settings.moduleswitches) and
  1616. (pi_needs_implicit_finally in flags))) then
  1617. Internalerror(2019021005);
  1618. { Position markers are only used to insert additional code after the secondpass
  1619. and before this point. They are of no use in optimizer. Instead of checking and
  1620. ignoring all over the optimizer, just remove them here. }
  1621. delete_marker(entry_asmnode);
  1622. delete_marker(loadpara_asmnode);
  1623. delete_marker(exitlabel_asmnode);
  1624. delete_marker(stackcheck_asmnode);
  1625. delete_marker(init_asmnode);
  1626. {$ifndef NoOpt}
  1627. if not(cs_no_regalloc in current_settings.globalswitches) then
  1628. begin
  1629. if (cs_opt_level1 in current_settings.optimizerswitches) and
  1630. { do not optimize pure assembler procedures }
  1631. not(pi_is_assembler in flags) then
  1632. optimize(aktproccode);
  1633. {$ifndef i386}
  1634. { schedule after assembler optimization, it could have brought up
  1635. new schedule possibilities }
  1636. if (cs_opt_scheduler in current_settings.optimizerswitches) and
  1637. { do not optimize pure assembler procedures }
  1638. not(pi_is_assembler in flags) then
  1639. preregallocschedule(aktproccode);
  1640. {$endif i386}
  1641. end;
  1642. {$endif NoOpt}
  1643. { Perform target-specific processing if necessary }
  1644. postprocess_code;
  1645. { Add end symbol and debug info }
  1646. { this must be done after the pcrelativedata is appended else the distance calculation of
  1647. insertpcrelativedata will be wrong, further the pc indirect data is part of the procedure
  1648. so it should be inserted before the end symbol (FK)
  1649. }
  1650. current_filepos:=exitpos;
  1651. hlcg.gen_proc_symbol_end(templist);
  1652. aktproccode.concatlist(templist);
  1653. { insert line debuginfo }
  1654. if (cs_debuginfo in current_settings.moduleswitches) or
  1655. (cs_use_lineinfo in current_settings.globalswitches) then
  1656. current_debuginfo.insertlineinfo(aktproccode);
  1657. finish_eh;
  1658. hlcg.record_generated_code_for_procdef(current_procinfo.procdef,aktproccode,aktlocaldata);
  1659. { only now we can remove the temps }
  1660. if (procdef.proctypeoption<>potype_exceptfilter) then
  1661. begin
  1662. tg.resettempgen;
  1663. tg.free;
  1664. tg:=nil;
  1665. end;
  1666. { stop tempgen and ra }
  1667. hlcg.done_register_allocators;
  1668. destroy_hlcodegen;
  1669. end;
  1670. dfabuilder.free;
  1671. { restore symtablestack }
  1672. remove_from_symtablestack;
  1673. { restore }
  1674. templist.free;
  1675. current_settings.maxfpuregisters:=oldmaxfpuregisters;
  1676. current_filepos:=oldfilepos;
  1677. current_structdef:=old_current_structdef;
  1678. current_procinfo:=old_current_procinfo;
  1679. end;
  1680. procedure tcgprocinfo.add_to_symtablestack;
  1681. begin
  1682. { insert symtables for the class, but only if it is no nested function }
  1683. if assigned(procdef.struct) and
  1684. not(assigned(parent) and
  1685. assigned(parent.procdef) and
  1686. assigned(parent.procdef.struct)) then
  1687. push_nested_hierarchy(procdef.struct);
  1688. { insert parasymtable in symtablestack when parsing
  1689. a function }
  1690. if procdef.parast.symtablelevel>=normal_function_level then
  1691. symtablestack.push(procdef.parast);
  1692. { insert localsymtable, except for the main procedure
  1693. (in that case the localst is the unit's static symtable,
  1694. which is already on the stack) }
  1695. if procdef.localst.symtablelevel>=normal_function_level then
  1696. symtablestack.push(procdef.localst);
  1697. end;
  1698. procedure tcgprocinfo.remove_from_symtablestack;
  1699. begin
  1700. { remove localsymtable }
  1701. if procdef.localst.symtablelevel>=normal_function_level then
  1702. symtablestack.pop(procdef.localst);
  1703. { remove parasymtable }
  1704. if procdef.parast.symtablelevel>=normal_function_level then
  1705. symtablestack.pop(procdef.parast);
  1706. { remove symtables for the class, but only if it is no nested function }
  1707. if assigned(procdef.struct) and
  1708. not(assigned(parent) and
  1709. assigned(parent.procdef) and
  1710. assigned(parent.procdef.struct)) then
  1711. pop_nested_hierarchy(procdef.struct);
  1712. end;
  1713. procedure tcgprocinfo.resetprocdef;
  1714. begin
  1715. { remove code tree, if not inline procedure }
  1716. if assigned(code) then
  1717. begin
  1718. { the inline procedure has already got a copy of the tree
  1719. stored in procdef.inlininginfo }
  1720. code.free;
  1721. code:=nil;
  1722. end;
  1723. end;
  1724. procedure tcgprocinfo.parse_body;
  1725. var
  1726. old_current_procinfo : tprocinfo;
  1727. old_block_type : tblock_type;
  1728. st : TSymtable;
  1729. old_current_structdef: tabstractrecorddef;
  1730. old_current_genericdef,
  1731. old_current_specializedef: tstoreddef;
  1732. parentfpinitblock: tnode;
  1733. old_parse_generic: boolean;
  1734. recordtokens : boolean;
  1735. begin
  1736. old_current_procinfo:=current_procinfo;
  1737. old_block_type:=block_type;
  1738. old_current_structdef:=current_structdef;
  1739. old_current_genericdef:=current_genericdef;
  1740. old_current_specializedef:=current_specializedef;
  1741. old_parse_generic:=parse_generic;
  1742. current_procinfo:=self;
  1743. current_structdef:=procdef.struct;
  1744. { check if the definitions of certain types are available which might not be available in older rtls and
  1745. which are assigned "on the fly" in types_dec }
  1746. {$ifndef jvm}
  1747. if not assigned(rec_exceptaddr) then
  1748. Message1(cg_f_internal_type_not_found,'TEXCEPTADDR');
  1749. if not assigned(rec_tguid) then
  1750. Message1(cg_f_internal_type_not_found,'TGUID');
  1751. if not assigned(rec_jmp_buf) then
  1752. Message1(cg_f_internal_type_not_found,'TJMPBUF');
  1753. {$endif}
  1754. { if the procdef is truly a generic (thus takes parameters itself) then
  1755. /that/ is our genericdef, not the - potentially - generic struct }
  1756. if procdef.is_generic then
  1757. begin
  1758. current_genericdef:=procdef;
  1759. parse_generic:=true;
  1760. end
  1761. else if assigned(current_structdef) and (df_generic in current_structdef.defoptions) then
  1762. begin
  1763. current_genericdef:=current_structdef;
  1764. parse_generic:=true;
  1765. end;
  1766. if assigned(current_structdef) and (df_specialization in current_structdef.defoptions) then
  1767. current_specializedef:=current_structdef;
  1768. { calculate the lexical level }
  1769. if procdef.parast.symtablelevel>maxnesting then
  1770. Message(parser_e_too_much_lexlevel);
  1771. block_type:=bt_body;
  1772. {$ifdef state_tracking}
  1773. { aktstate:=Tstate_storage.create;}
  1774. {$endif state_tracking}
  1775. { allocate the symbol for this procedure }
  1776. alloc_proc_symbol(procdef);
  1777. { add parast/localst to symtablestack }
  1778. add_to_symtablestack;
  1779. { save entry info }
  1780. entrypos:=current_filepos;
  1781. entryswitches:=current_settings.localswitches;
  1782. recordtokens:=procdef.is_generic or
  1783. (
  1784. assigned(procdef.struct) and
  1785. (df_generic in procdef.struct.defoptions) and
  1786. assigned(procdef.owner) and
  1787. (procdef.owner.defowner=procdef.struct)
  1788. );
  1789. if recordtokens then
  1790. begin
  1791. { start token recorder for generic template }
  1792. procdef.initgeneric;
  1793. current_scanner.startrecordtokens(procdef.generictokenbuf);
  1794. end;
  1795. { parse the code ... }
  1796. code:=block(current_module.islibrary);
  1797. if recordtokens then
  1798. begin
  1799. { stop token recorder for generic template }
  1800. current_scanner.stoprecordtokens;
  1801. { Give an error for accesses in the static symtable that aren't visible
  1802. outside the current unit }
  1803. st:=procdef.owner;
  1804. while (st.symtabletype in [ObjectSymtable,recordsymtable]) do
  1805. st:=st.defowner.owner;
  1806. if (pi_uses_static_symtable in flags) and
  1807. (st.symtabletype<>staticsymtable) then
  1808. Message(parser_e_global_generic_references_static);
  1809. end;
  1810. { save exit info }
  1811. exitswitches:=current_settings.localswitches;
  1812. exitpos:=last_endtoken_filepos;
  1813. { the procedure is now defined }
  1814. procdef.forwarddef:=false;
  1815. if assigned(code) then
  1816. begin
  1817. { get a better entry point }
  1818. entrypos:=code.fileinfo;
  1819. { Finish type checking pass }
  1820. do_typecheckpass(code);
  1821. if assigned(procdef.parentfpinitblock) then
  1822. begin
  1823. if assigned(tblocknode(procdef.parentfpinitblock).left) then
  1824. begin
  1825. parentfpinitblock:=procdef.parentfpinitblock;
  1826. do_typecheckpass(parentfpinitblock);
  1827. procdef.parentfpinitblock:=parentfpinitblock;
  1828. end
  1829. end;
  1830. end;
  1831. { Check for unused labels, forwards, symbols for procedures. Static
  1832. symtable is checked in pmodules.
  1833. The check must be done after the typecheckpass }
  1834. if (Errorcount=0) and
  1835. (tstoredsymtable(procdef.localst).symtabletype<>staticsymtable) then
  1836. begin
  1837. { check if forwards are resolved }
  1838. tstoredsymtable(procdef.localst).check_forwards;
  1839. { check if all labels are used }
  1840. tstoredsymtable(procdef.localst).checklabels;
  1841. { check for unused symbols, but only if there is no asm block }
  1842. if not(pi_has_assembler_block in flags) then
  1843. begin
  1844. tstoredsymtable(procdef.localst).allsymbolsused;
  1845. tstoredsymtable(procdef.parast).allsymbolsused;
  1846. end;
  1847. end;
  1848. if (po_inline in procdef.procoptions) and
  1849. { Can we inline this procedure? }
  1850. checknodeinlining(procdef) then
  1851. CreateInlineInfo;
  1852. { Print the node to tree.log }
  1853. if paraprintnodetree=1 then
  1854. printproc( 'after parsing');
  1855. { ... remove symbol tables }
  1856. remove_from_symtablestack;
  1857. {$ifdef state_tracking}
  1858. { aktstate.destroy;}
  1859. {$endif state_tracking}
  1860. current_structdef:=old_current_structdef;
  1861. current_genericdef:=old_current_genericdef;
  1862. current_specializedef:=old_current_specializedef;
  1863. current_procinfo:=old_current_procinfo;
  1864. parse_generic:=old_parse_generic;
  1865. { Restore old state }
  1866. block_type:=old_block_type;
  1867. end;
  1868. {****************************************************************************
  1869. PROCEDURE/FUNCTION PARSING
  1870. ****************************************************************************}
  1871. procedure check_init_paras(p:TObject;arg:pointer);
  1872. begin
  1873. if tsym(p).typ<>paravarsym then
  1874. exit;
  1875. with tparavarsym(p) do
  1876. if (is_managed_type(vardef) and
  1877. (varspez in [vs_value,vs_out])) or
  1878. (is_shortstring(vardef) and
  1879. (varspez=vs_value)) then
  1880. include(current_procinfo.flags,pi_do_call);
  1881. end;
  1882. procedure read_proc_body(old_current_procinfo:tprocinfo;pd:tprocdef);
  1883. {
  1884. Parses the procedure directives, then parses the procedure body, then
  1885. generates the code for it
  1886. }
  1887. var
  1888. oldfailtokenmode : tmodeswitches;
  1889. isnestedproc : boolean;
  1890. begin
  1891. Message1(parser_d_procedure_start,pd.fullprocname(false));
  1892. oldfailtokenmode:=[];
  1893. { create a new procedure }
  1894. current_procinfo:=cprocinfo.create(old_current_procinfo);
  1895. current_module.procinfo:=current_procinfo;
  1896. current_procinfo.procdef:=pd;
  1897. isnestedproc:=(current_procinfo.procdef.parast.symtablelevel>normal_function_level);
  1898. { Insert mangledname }
  1899. pd.aliasnames.insert(pd.mangledname);
  1900. { Handle Export of this procedure }
  1901. if (po_exports in pd.procoptions) and
  1902. (target_info.system in [system_i386_os2,system_i386_emx]) then
  1903. begin
  1904. pd.aliasnames.insert(pd.procsym.realname);
  1905. if cs_link_deffile in current_settings.globalswitches then
  1906. deffile.AddExport(pd.mangledname);
  1907. end;
  1908. { Insert result variables in the localst }
  1909. insert_funcret_local(pd);
  1910. { check if there are para's which require initing -> set }
  1911. { pi_do_call (if not yet set) }
  1912. if not(pi_do_call in current_procinfo.flags) then
  1913. pd.parast.SymList.ForEachCall(@check_init_paras,nil);
  1914. { set _FAIL as keyword if constructor }
  1915. if (pd.proctypeoption=potype_constructor) then
  1916. begin
  1917. oldfailtokenmode:=tokeninfo^[_FAIL].keyword;
  1918. tokeninfo^[_FAIL].keyword:=alllanguagemodes;
  1919. end;
  1920. tcgprocinfo(current_procinfo).parse_body;
  1921. { reset _FAIL as _SELF normal }
  1922. if (pd.proctypeoption=potype_constructor) then
  1923. tokeninfo^[_FAIL].keyword:=oldfailtokenmode;
  1924. { When it's a nested procedure then defer the code generation,
  1925. when back at normal function level then generate the code
  1926. for all defered nested procedures and the current procedure }
  1927. if not isnestedproc then
  1928. begin
  1929. if not(df_generic in current_procinfo.procdef.defoptions) then
  1930. begin
  1931. { also generate the bodies for all previously done
  1932. specializations so that we might inline them }
  1933. generate_specialization_procs;
  1934. tcgprocinfo(current_procinfo).generate_code_tree;
  1935. end;
  1936. end;
  1937. { release procinfo }
  1938. if tprocinfo(current_module.procinfo)<>current_procinfo then
  1939. internalerror(200304274);
  1940. current_module.procinfo:=current_procinfo.parent;
  1941. { For specialization we didn't record the last semicolon. Moving this parsing
  1942. into the parse_body routine is not done because of having better file position
  1943. information available }
  1944. if not current_procinfo.procdef.is_specialization and
  1945. (
  1946. not assigned(current_procinfo.procdef.struct) or
  1947. not (df_specialization in current_procinfo.procdef.struct.defoptions)
  1948. or not (
  1949. assigned(current_procinfo.procdef.owner) and
  1950. (current_procinfo.procdef.owner.defowner=current_procinfo.procdef.struct)
  1951. )
  1952. ) then
  1953. consume(_SEMICOLON);
  1954. if not isnestedproc then
  1955. { current_procinfo is checked for nil later on }
  1956. freeandnil(current_procinfo);
  1957. end;
  1958. procedure read_proc_body(pd:tprocdef);
  1959. var
  1960. old_module_procinfo : tobject;
  1961. old_current_procinfo : tprocinfo;
  1962. begin
  1963. old_current_procinfo:=current_procinfo;
  1964. old_module_procinfo:=current_module.procinfo;
  1965. current_procinfo:=nil;
  1966. current_module.procinfo:=nil;
  1967. read_proc_body(nil,pd);
  1968. current_procinfo:=old_current_procinfo;
  1969. current_module.procinfo:=old_module_procinfo;
  1970. end;
  1971. procedure read_proc(isclassmethod:boolean; usefwpd: tprocdef;isgeneric:boolean);
  1972. {
  1973. Parses the procedure directives, then parses the procedure body, then
  1974. generates the code for it
  1975. }
  1976. var
  1977. old_current_procinfo : tprocinfo;
  1978. old_current_structdef: tabstractrecorddef;
  1979. old_current_genericdef,
  1980. old_current_specializedef: tstoreddef;
  1981. pdflags : tpdflags;
  1982. pd,firstpd : tprocdef;
  1983. {$ifdef genericdef_for_nested}
  1984. def : tprocdef;
  1985. srsym : tsym;
  1986. i : longint;
  1987. {$endif genericdef_for_nested}
  1988. begin
  1989. { save old state }
  1990. old_current_procinfo:=current_procinfo;
  1991. old_current_structdef:=current_structdef;
  1992. old_current_genericdef:=current_genericdef;
  1993. old_current_specializedef:=current_specializedef;
  1994. { reset current_procinfo.procdef to nil to be sure that nothing is writing
  1995. to another procdef }
  1996. current_procinfo:=nil;
  1997. current_structdef:=nil;
  1998. current_genericdef:=nil;
  1999. current_specializedef:=nil;
  2000. if not assigned(usefwpd) then
  2001. { parse procedure declaration }
  2002. pd:=parse_proc_dec(isclassmethod,old_current_structdef,isgeneric)
  2003. else
  2004. pd:=usefwpd;
  2005. { set the default function options }
  2006. if parse_only then
  2007. begin
  2008. pd.forwarddef:=true;
  2009. { set also the interface flag, for better error message when the
  2010. implementation doesn't match this header }
  2011. pd.interfacedef:=true;
  2012. include(pd.procoptions,po_global);
  2013. pdflags:=[pd_interface];
  2014. end
  2015. else
  2016. begin
  2017. pdflags:=[pd_body];
  2018. if (not current_module.in_interface) then
  2019. include(pdflags,pd_implemen);
  2020. if (not current_module.is_unit) or
  2021. create_smartlink_library then
  2022. include(pd.procoptions,po_global);
  2023. pd.forwarddef:=false;
  2024. end;
  2025. if not assigned(usefwpd) then
  2026. begin
  2027. { parse the directives that may follow }
  2028. parse_proc_directives(pd,pdflags);
  2029. { hint directives, these can be separated by semicolons here,
  2030. that needs to be handled here with a loop (PFV) }
  2031. while try_consume_hintdirective(pd.symoptions,pd.deprecatedmsg) do
  2032. Consume(_SEMICOLON);
  2033. { Set calling convention }
  2034. if parse_only then
  2035. handle_calling_convention(pd,hcc_default_actions_intf)
  2036. else
  2037. handle_calling_convention(pd,hcc_default_actions_impl)
  2038. end;
  2039. { search for forward declarations }
  2040. if not proc_add_definition(pd) then
  2041. begin
  2042. { A method must be forward defined (in the object declaration) }
  2043. if assigned(pd.struct) and
  2044. (not assigned(old_current_structdef)) then
  2045. begin
  2046. MessagePos1(pd.fileinfo,parser_e_header_dont_match_any_member,pd.fullprocname(false));
  2047. tprocsym(pd.procsym).write_parameter_lists(pd);
  2048. end
  2049. else
  2050. begin
  2051. { Give a better error if there is a forward def in the interface and only
  2052. a single implementation }
  2053. firstpd:=tprocdef(tprocsym(pd.procsym).ProcdefList[0]);
  2054. if (not pd.forwarddef) and
  2055. (not pd.interfacedef) and
  2056. (tprocsym(pd.procsym).ProcdefList.Count>1) and
  2057. firstpd.forwarddef and
  2058. firstpd.interfacedef and
  2059. not(tprocsym(pd.procsym).ProcdefList.Count>2) and
  2060. { don't give an error if it may be an overload }
  2061. not(m_fpc in current_settings.modeswitches) and
  2062. (not(po_overload in pd.procoptions) or
  2063. not(po_overload in firstpd.procoptions)) then
  2064. begin
  2065. MessagePos1(pd.fileinfo,parser_e_header_dont_match_forward,pd.fullprocname(false));
  2066. tprocsym(pd.procsym).write_parameter_lists(pd);
  2067. end
  2068. else
  2069. begin
  2070. if pd.is_generic and not assigned(pd.struct) then
  2071. tprocsym(pd.procsym).owner.includeoption(sto_has_generic);
  2072. end;
  2073. end;
  2074. end;
  2075. { Set mangled name }
  2076. proc_set_mangledname(pd);
  2077. { inherit generic flags from parent routine }
  2078. if assigned(old_current_procinfo) and
  2079. (old_current_procinfo.procdef.defoptions*[df_specialization,df_generic]<>[]) then
  2080. begin
  2081. if df_generic in old_current_procinfo.procdef.defoptions then
  2082. include(pd.defoptions,df_generic);
  2083. if df_specialization in old_current_procinfo.procdef.defoptions then
  2084. begin
  2085. include(pd.defoptions,df_specialization);
  2086. { the procdefs encountered here are nested procdefs of which
  2087. their complete definition also resides inside the current token
  2088. stream, thus access to their genericdef is not required }
  2089. {$ifdef genericdef_for_nested}
  2090. { find the corresponding routine in the generic routine }
  2091. if not assigned(old_current_procinfo.procdef.genericdef) then
  2092. internalerror(2016121701);
  2093. srsym:=tsym(tprocdef(old_current_procinfo.procdef.genericdef).getsymtable(gs_local).find(pd.procsym.name));
  2094. if not assigned(srsym) or (srsym.typ<>procsym) then
  2095. internalerror(2016121702);
  2096. { in practice the generic procdef should be at the same index
  2097. as the index of the current procdef, but as there *might* be
  2098. differences between the amount of defs generated for the
  2099. specialization and the generic search for the def using
  2100. parameter comparison }
  2101. for i:=0 to tprocsym(srsym).procdeflist.count-1 do
  2102. begin
  2103. def:=tprocdef(tprocsym(srsym).procdeflist[i]);
  2104. if (compare_paras(def.paras,pd.paras,cp_none,[cpo_ignorehidden,cpo_openequalisexact,cpo_ignoreuniv])=te_exact) and
  2105. (compare_defs(def.returndef,pd.returndef,nothingn)=te_exact) then
  2106. begin
  2107. pd.genericdef:=def;
  2108. break;
  2109. end;
  2110. end;
  2111. if not assigned(pd.genericdef) then
  2112. internalerror(2016121703);
  2113. {$endif}
  2114. end;
  2115. end;
  2116. { compile procedure when a body is needed }
  2117. if (pd_body in pdflags) then
  2118. begin
  2119. read_proc_body(old_current_procinfo,pd);
  2120. end
  2121. else
  2122. begin
  2123. { Handle imports }
  2124. if (po_external in pd.procoptions) then
  2125. begin
  2126. import_external_proc(pd);
  2127. {$ifdef cpuhighleveltarget}
  2128. { it's hard to factor this out in a virtual method, because the
  2129. generic version (the one inside this ifdef) doesn't fit in
  2130. hlcgobj but in symcreat or here, while the other version
  2131. doesn't fit in symcreat (since it uses the code generator).
  2132. Maybe we need another class for this kind of code that could
  2133. either be symcreat- or hlcgobj-based
  2134. }
  2135. if (not pd.forwarddef) and
  2136. (pd.hasforward) and
  2137. (proc_get_importname(pd)<>'') then
  2138. call_through_new_name(pd,proc_get_importname(pd))
  2139. else
  2140. {$endif cpuhighleveltarget}
  2141. begin
  2142. create_hlcodegen;
  2143. hlcg.handle_external_proc(
  2144. current_asmdata.asmlists[al_procedures],
  2145. pd,
  2146. proc_get_importname(pd));
  2147. destroy_hlcodegen;
  2148. end
  2149. end;
  2150. end;
  2151. { always register public functions that are only declared in the
  2152. implementation section as they might be called using an external
  2153. declaration from another unit }
  2154. if (po_global in pd.procoptions) and
  2155. not pd.interfacedef and
  2156. ([df_generic,df_specialization]*pd.defoptions=[]) then
  2157. begin
  2158. pd.register_def;
  2159. pd.procsym.register_sym;
  2160. end;
  2161. { make sure that references to forward-declared functions are not }
  2162. { treated as references to external symbols, needed for darwin. }
  2163. { make sure we don't change the binding of real external symbols }
  2164. if (([po_external,po_weakexternal]*pd.procoptions)=[]) and (pocall_internproc<>pd.proccalloption) then
  2165. begin
  2166. if (po_global in pd.procoptions) or
  2167. (cs_profile in current_settings.moduleswitches) then
  2168. current_asmdata.DefineAsmSymbol(pd.mangledname,AB_GLOBAL,AT_FUNCTION,pd)
  2169. else
  2170. current_asmdata.DefineAsmSymbol(pd.mangledname,AB_LOCAL,AT_FUNCTION,pd);
  2171. end;
  2172. current_structdef:=old_current_structdef;
  2173. current_genericdef:=old_current_genericdef;
  2174. current_specializedef:=old_current_specializedef;
  2175. current_procinfo:=old_current_procinfo;
  2176. end;
  2177. procedure import_external_proc(pd:tprocdef);
  2178. var
  2179. name : string;
  2180. begin
  2181. if not (po_external in pd.procoptions) then
  2182. internalerror(2015121101);
  2183. { Import DLL specified? }
  2184. if assigned(pd.import_dll) then
  2185. begin
  2186. if assigned (pd.import_name) then
  2187. current_module.AddExternalImport(pd.import_dll^,
  2188. pd.import_name^,proc_get_importname(pd),
  2189. pd.import_nr,false,false)
  2190. else
  2191. current_module.AddExternalImport(pd.import_dll^,
  2192. proc_get_importname(pd),proc_get_importname(pd),
  2193. pd.import_nr,false,true);
  2194. end
  2195. else
  2196. begin
  2197. name:=proc_get_importname(pd);
  2198. { add import name to external list for DLL scanning }
  2199. if tf_has_dllscanner in target_info.flags then
  2200. current_module.dllscannerinputlist.Add(name,pd);
  2201. { needed for units that use functions in packages this way }
  2202. current_module.add_extern_asmsym(name,AB_EXTERNAL,AT_FUNCTION);
  2203. end;
  2204. end;
  2205. {****************************************************************************
  2206. DECLARATION PARSING
  2207. ****************************************************************************}
  2208. { search in symtablestack for not complete classes }
  2209. procedure check_forward_class(p:TObject;arg:pointer);
  2210. begin
  2211. if (tsym(p).typ=typesym) and
  2212. (ttypesym(p).typedef.typ=objectdef) and
  2213. (oo_is_forward in tobjectdef(ttypesym(p).typedef).objectoptions) then
  2214. MessagePos1(tsym(p).fileinfo,sym_e_forward_type_not_resolved,tsym(p).realname);
  2215. end;
  2216. procedure read_declarations(islibrary : boolean);
  2217. var
  2218. hadgeneric : boolean;
  2219. procedure handle_unexpected_had_generic;
  2220. begin
  2221. if hadgeneric then
  2222. begin
  2223. Message(parser_e_procedure_or_function_expected);
  2224. hadgeneric:=false;
  2225. end;
  2226. end;
  2227. var
  2228. is_classdef:boolean;
  2229. begin
  2230. is_classdef:=false;
  2231. hadgeneric:=false;
  2232. repeat
  2233. if not assigned(current_procinfo) then
  2234. internalerror(200304251);
  2235. case token of
  2236. _LABEL:
  2237. begin
  2238. handle_unexpected_had_generic;
  2239. label_dec;
  2240. end;
  2241. _CONST:
  2242. begin
  2243. handle_unexpected_had_generic;
  2244. const_dec(hadgeneric);
  2245. end;
  2246. _TYPE:
  2247. begin
  2248. handle_unexpected_had_generic;
  2249. type_dec(hadgeneric);
  2250. end;
  2251. _VAR:
  2252. begin
  2253. handle_unexpected_had_generic;
  2254. var_dec(hadgeneric);
  2255. end;
  2256. _THREADVAR:
  2257. begin
  2258. handle_unexpected_had_generic;
  2259. threadvar_dec(hadgeneric);
  2260. end;
  2261. _CLASS:
  2262. begin
  2263. is_classdef:=false;
  2264. if try_to_consume(_CLASS) then
  2265. begin
  2266. { class modifier is only allowed for procedures, functions, }
  2267. { constructors, destructors }
  2268. if not((token in [_FUNCTION,_PROCEDURE,_DESTRUCTOR,_OPERATOR]) or (token=_CONSTRUCTOR)) and
  2269. not((token=_ID) and (idtoken=_OPERATOR)) then
  2270. Message(parser_e_procedure_or_function_expected);
  2271. if is_interface(current_structdef) then
  2272. Message(parser_e_no_static_method_in_interfaces)
  2273. else
  2274. { class methods are also allowed for Objective-C protocols }
  2275. is_classdef:=true;
  2276. end;
  2277. end;
  2278. _CONSTRUCTOR,
  2279. _DESTRUCTOR,
  2280. _FUNCTION,
  2281. _PROCEDURE,
  2282. _OPERATOR:
  2283. begin
  2284. if hadgeneric and not (token in [_PROCEDURE,_FUNCTION]) then
  2285. begin
  2286. Message(parser_e_procedure_or_function_expected);
  2287. hadgeneric:=false;
  2288. end;
  2289. read_proc(is_classdef,nil,hadgeneric);
  2290. is_classdef:=false;
  2291. hadgeneric:=false;
  2292. end;
  2293. _EXPORTS:
  2294. begin
  2295. handle_unexpected_had_generic;
  2296. if (current_procinfo.procdef.localst.symtablelevel>main_program_level) then
  2297. begin
  2298. Message(parser_e_syntax_error);
  2299. consume_all_until(_SEMICOLON);
  2300. end
  2301. else if islibrary or
  2302. (target_info.system in systems_unit_program_exports) then
  2303. read_exports
  2304. else
  2305. begin
  2306. Message(parser_w_unsupported_feature);
  2307. consume(_BEGIN);
  2308. end;
  2309. end;
  2310. _PROPERTY:
  2311. begin
  2312. handle_unexpected_had_generic;
  2313. if (m_fpc in current_settings.modeswitches) then
  2314. property_dec
  2315. else
  2316. break;
  2317. end;
  2318. else
  2319. begin
  2320. case idtoken of
  2321. _RESOURCESTRING:
  2322. begin
  2323. handle_unexpected_had_generic;
  2324. { m_class is needed, because the resourcestring
  2325. loading is in the ObjPas unit }
  2326. { if (m_class in current_settings.modeswitches) then}
  2327. resourcestring_dec(hadgeneric)
  2328. { else
  2329. break;}
  2330. end;
  2331. _OPERATOR:
  2332. begin
  2333. handle_unexpected_had_generic;
  2334. if is_classdef then
  2335. begin
  2336. read_proc(is_classdef,nil,false);
  2337. is_classdef:=false;
  2338. end
  2339. else
  2340. break;
  2341. end;
  2342. _GENERIC:
  2343. begin
  2344. handle_unexpected_had_generic;
  2345. if not (m_delphi in current_settings.modeswitches) then
  2346. begin
  2347. consume(_ID);
  2348. hadgeneric:=true;
  2349. end
  2350. else
  2351. break;
  2352. end
  2353. else
  2354. break;
  2355. end;
  2356. end;
  2357. end;
  2358. until false;
  2359. { add implementations for synthetic method declarations added by
  2360. the compiler (not for unit/program init functions, their localst
  2361. is the staticst -> would duplicate the work done in pmodules) }
  2362. if current_procinfo.procdef.localst.symtabletype=localsymtable then
  2363. add_synthetic_method_implementations(current_procinfo.procdef.localst);
  2364. { check for incomplete class definitions, this is only required
  2365. for fpc modes }
  2366. if (m_fpc in current_settings.modeswitches) then
  2367. current_procinfo.procdef.localst.SymList.ForEachCall(@check_forward_class,nil);
  2368. end;
  2369. procedure read_interface_declarations;
  2370. var
  2371. hadgeneric : boolean;
  2372. procedure handle_unexpected_had_generic;
  2373. begin
  2374. if hadgeneric then
  2375. begin
  2376. Message(parser_e_procedure_or_function_expected);
  2377. hadgeneric:=false;
  2378. end;
  2379. end;
  2380. begin
  2381. hadgeneric:=false;
  2382. repeat
  2383. case token of
  2384. _CONST :
  2385. begin
  2386. handle_unexpected_had_generic;
  2387. const_dec(hadgeneric);
  2388. end;
  2389. _TYPE :
  2390. begin
  2391. handle_unexpected_had_generic;
  2392. type_dec(hadgeneric);
  2393. end;
  2394. _VAR :
  2395. begin
  2396. handle_unexpected_had_generic;
  2397. var_dec(hadgeneric);
  2398. end;
  2399. _THREADVAR :
  2400. begin
  2401. handle_unexpected_had_generic;
  2402. threadvar_dec(hadgeneric);
  2403. end;
  2404. _FUNCTION,
  2405. _PROCEDURE,
  2406. _OPERATOR :
  2407. begin
  2408. if hadgeneric and not (token in [_FUNCTION, _PROCEDURE]) then
  2409. begin
  2410. message(parser_e_procedure_or_function_expected);
  2411. hadgeneric:=false;
  2412. end;
  2413. read_proc(false,nil,hadgeneric);
  2414. hadgeneric:=false;
  2415. end;
  2416. else
  2417. begin
  2418. case idtoken of
  2419. _RESOURCESTRING :
  2420. begin
  2421. handle_unexpected_had_generic;
  2422. resourcestring_dec(hadgeneric);
  2423. end;
  2424. _PROPERTY:
  2425. begin
  2426. handle_unexpected_had_generic;
  2427. if (m_fpc in current_settings.modeswitches) then
  2428. property_dec
  2429. else
  2430. break;
  2431. end;
  2432. _GENERIC:
  2433. begin
  2434. handle_unexpected_had_generic;
  2435. if not (m_delphi in current_settings.modeswitches) then
  2436. begin
  2437. hadgeneric:=true;
  2438. consume(_ID);
  2439. end
  2440. else
  2441. break;
  2442. end
  2443. else
  2444. break;
  2445. end;
  2446. end;
  2447. end;
  2448. until false;
  2449. { check for incomplete class definitions, this is only required
  2450. for fpc modes }
  2451. if (m_fpc in current_settings.modeswitches) then
  2452. symtablestack.top.SymList.ForEachCall(@check_forward_class,nil);
  2453. end;
  2454. end.