psub.pas 68 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809
  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. interface
  20. uses
  21. cclasses,globals,
  22. node,nbas,
  23. symdef,procinfo;
  24. type
  25. tcgprocinfo = class(tprocinfo)
  26. private
  27. procedure add_entry_exit_code;
  28. public
  29. { code for the subroutine as tree }
  30. code : tnode;
  31. { positions in the tree for init/final }
  32. entry_asmnode,
  33. loadpara_asmnode,
  34. exitlabel_asmnode,
  35. stackcheck_asmnode,
  36. init_asmnode,
  37. final_asmnode : tasmnode;
  38. { list to store the procinfo's of the nested procedures }
  39. nestedprocs : tlinkedlist;
  40. constructor create(aparent:tprocinfo);override;
  41. destructor destroy;override;
  42. procedure printproc;
  43. procedure generate_code;
  44. procedure resetprocdef;
  45. procedure add_to_symtablestack;
  46. procedure remove_from_symtablestack;
  47. procedure parse_body;
  48. function stack_tainting_parameter : boolean;
  49. function has_assembler_child : boolean;
  50. end;
  51. procedure printnode_reset;
  52. { reads the declaration blocks }
  53. procedure read_declarations(islibrary : boolean);
  54. { reads declarations in the interface part of a unit }
  55. procedure read_interface_declarations;
  56. procedure generate_specialization_procs;
  57. implementation
  58. uses
  59. sysutils,
  60. { common }
  61. cutils,
  62. { global }
  63. globtype,tokens,verbose,comphook,
  64. systems,
  65. { aasm }
  66. cpubase,aasmbase,aasmtai,aasmdata,
  67. { symtable }
  68. symconst,symbase,symsym,symtype,symtable,defutil,
  69. paramgr,
  70. ppu,fmodule,
  71. { pass 1 }
  72. nutils,nld,ncal,ncon,nflw,nadd,ncnv,nmem,
  73. pass_1,
  74. {$ifdef state_tracking}
  75. nstate,
  76. {$endif state_tracking}
  77. { pass 2 }
  78. {$ifndef NOPASS2}
  79. pass_2,
  80. {$endif}
  81. { parser }
  82. scanner,import,gendef,
  83. pbase,pstatmnt,pdecl,pdecsub,pexports,
  84. { codegen }
  85. tgobj,cgbase,cgobj,dbgbase,
  86. ncgutil,regvars,
  87. opttail,
  88. optcse,
  89. optdfa
  90. {$if defined(arm) or defined(powerpc) or defined(powerpc64)}
  91. ,aasmcpu
  92. {$endif arm}
  93. {$ifndef NOOPT}
  94. {$ifdef i386}
  95. ,aopt386
  96. {$else i386}
  97. ,aopt
  98. {$endif i386}
  99. {$endif}
  100. ;
  101. {****************************************************************************
  102. PROCEDURE/FUNCTION BODY PARSING
  103. ****************************************************************************}
  104. procedure initializevars(p:TObject;arg:pointer);
  105. var
  106. b : tblocknode;
  107. begin
  108. if not (tsym(p).typ in [localvarsym,staticvarsym]) then
  109. exit;
  110. with tabstractnormalvarsym(p) do
  111. begin
  112. if assigned(defaultconstsym) then
  113. begin
  114. b:=tblocknode(arg);
  115. b.left:=cstatementnode.create(
  116. cassignmentnode.create(
  117. cloadnode.create(tsym(p),tsym(p).owner),
  118. cloadnode.create(defaultconstsym,defaultconstsym.owner)),
  119. b.left);
  120. end;
  121. end;
  122. end;
  123. procedure check_finalize_paras(p:TObject;arg:pointer);
  124. begin
  125. if (tsym(p).typ=paravarsym) and
  126. (tparavarsym(p).varspez=vs_value) and
  127. not is_class(tparavarsym(p).vardef) and
  128. tparavarsym(p).vardef.needs_inittable then
  129. include(current_procinfo.flags,pi_needs_implicit_finally);
  130. end;
  131. procedure check_finalize_locals(p:TObject;arg:pointer);
  132. begin
  133. if (tsym(p).typ=localvarsym) and
  134. (tlocalvarsym(p).refs>0) and
  135. not(vo_is_funcret in tlocalvarsym(p).varoptions) and
  136. not(is_class(tlocalvarsym(p).vardef)) and
  137. tlocalvarsym(p).vardef.needs_inittable then
  138. include(current_procinfo.flags,pi_needs_implicit_finally);
  139. end;
  140. function block(islibrary : boolean) : tnode;
  141. begin
  142. { parse const,types and vars }
  143. read_declarations(islibrary);
  144. { do we have an assembler block without the po_assembler?
  145. we should allow this for Delphi compatibility (PFV) }
  146. if (token=_ASM) and (m_delphi in current_settings.modeswitches) then
  147. include(current_procinfo.procdef.procoptions,po_assembler);
  148. { Handle assembler block different }
  149. if (po_assembler in current_procinfo.procdef.procoptions) then
  150. begin
  151. block:=assembler_block;
  152. exit;
  153. end;
  154. {Unit initialization?.}
  155. if (
  156. assigned(current_procinfo.procdef.localst) and
  157. (current_procinfo.procdef.localst.symtablelevel=main_program_level) and
  158. (current_module.is_unit)
  159. ) or
  160. islibrary then
  161. begin
  162. if (token=_END) then
  163. begin
  164. consume(_END);
  165. { We need at least a node, else the entry/exit code is not
  166. generated and thus no PASCALMAIN symbol which we need (PFV) }
  167. if islibrary then
  168. block:=cnothingnode.create
  169. else
  170. block:=nil;
  171. end
  172. else
  173. begin
  174. if token=_INITIALIZATION then
  175. begin
  176. { The library init code is already called and does not
  177. need to be in the initfinal table (PFV) }
  178. if not islibrary then
  179. current_module.flags:=current_module.flags or uf_init;
  180. block:=statement_block(_INITIALIZATION);
  181. end
  182. else if (token=_FINALIZATION) then
  183. begin
  184. if (current_module.flags and uf_finalize)<>0 then
  185. block:=statement_block(_FINALIZATION)
  186. else
  187. begin
  188. { can we allow no INITIALIZATION for DLL ??
  189. I think it should work PM }
  190. block:=nil;
  191. exit;
  192. end;
  193. end
  194. else
  195. begin
  196. { The library init code is already called and does not
  197. need to be in the initfinal table (PFV) }
  198. if not islibrary then
  199. current_module.flags:=current_module.flags or uf_init;
  200. block:=statement_block(_BEGIN);
  201. end;
  202. end;
  203. end
  204. else
  205. begin
  206. block:=statement_block(_BEGIN);
  207. if current_procinfo.procdef.localst.symtabletype=localsymtable then
  208. current_procinfo.procdef.localst.SymList.ForEachCall(@initializevars,block);
  209. end;
  210. end;
  211. {****************************************************************************
  212. PROCEDURE/FUNCTION COMPILING
  213. ****************************************************************************}
  214. procedure printnode_reset;
  215. begin
  216. assign(printnodefile,treelogfilename);
  217. {$I-}
  218. rewrite(printnodefile);
  219. {$I+}
  220. if ioresult<>0 then
  221. begin
  222. Comment(V_Error,'Error creating '+treelogfilename);
  223. exit;
  224. end;
  225. close(printnodefile);
  226. end;
  227. function generate_bodyentry_block:tnode;
  228. var
  229. srsym : tsym;
  230. para : tcallparanode;
  231. newstatement : tstatementnode;
  232. hdef : tdef;
  233. begin
  234. result:=internalstatements(newstatement);
  235. if assigned(current_procinfo.procdef._class) then
  236. begin
  237. { a constructor needs a help procedure }
  238. if (current_procinfo.procdef.proctypeoption=potype_constructor) then
  239. begin
  240. if is_class(current_procinfo.procdef._class) then
  241. begin
  242. include(current_procinfo.flags,pi_needs_implicit_finally);
  243. srsym:=search_class_member(current_procinfo.procdef._class,'NEWINSTANCE');
  244. if assigned(srsym) and
  245. (srsym.typ=procsym) then
  246. begin
  247. { if vmt>1 then newinstance }
  248. addstatement(newstatement,cifnode.create(
  249. caddnode.create(gtn,
  250. ctypeconvnode.create_internal(
  251. load_vmt_pointer_node,
  252. voidpointertype),
  253. cpointerconstnode.create(1,voidpointertype)),
  254. cassignmentnode.create(
  255. ctypeconvnode.create_internal(
  256. load_self_pointer_node,
  257. voidpointertype),
  258. ccallnode.create(nil,tprocsym(srsym),srsym.owner,load_vmt_pointer_node,[])),
  259. nil));
  260. end
  261. else
  262. internalerror(200305108);
  263. end
  264. else
  265. if is_object(current_procinfo.procdef._class) then
  266. begin
  267. hdef:=current_procinfo.procdef._class;
  268. hdef:=tpointerdef.create(hdef);
  269. { parameter 3 : vmt_offset }
  270. { parameter 2 : address of pointer to vmt,
  271. this is required to allow setting the vmt to -1 to indicate
  272. that memory was allocated }
  273. { parameter 1 : self pointer }
  274. para:=ccallparanode.create(
  275. cordconstnode.create(current_procinfo.procdef._class.vmt_offset,s32inttype,false),
  276. ccallparanode.create(
  277. ctypeconvnode.create_internal(
  278. load_vmt_pointer_node,
  279. voidpointertype),
  280. ccallparanode.create(
  281. ctypeconvnode.create_internal(
  282. load_self_pointer_node,
  283. voidpointertype),
  284. nil)));
  285. addstatement(newstatement,cassignmentnode.create(
  286. ctypeconvnode.create_internal(
  287. load_self_pointer_node,
  288. voidpointertype),
  289. ccallnode.createintern('fpc_help_constructor',para)));
  290. end
  291. else
  292. internalerror(200305103);
  293. { if self=nil then exit
  294. calling fail instead of exit is useless because
  295. there is nothing to dispose (PFV) }
  296. addstatement(newstatement,cifnode.create(
  297. caddnode.create(equaln,
  298. load_self_pointer_node,
  299. cnilnode.create),
  300. cexitnode.create(nil),
  301. nil));
  302. end;
  303. { maybe call BeforeDestruction for classes }
  304. if (current_procinfo.procdef.proctypeoption=potype_destructor) and
  305. is_class(current_procinfo.procdef._class) then
  306. begin
  307. srsym:=search_class_member(current_procinfo.procdef._class,'BEFOREDESTRUCTION');
  308. if assigned(srsym) and
  309. (srsym.typ=procsym) then
  310. begin
  311. { if vmt>0 then beforedestruction }
  312. addstatement(newstatement,cifnode.create(
  313. caddnode.create(gtn,
  314. ctypeconvnode.create_internal(
  315. load_vmt_pointer_node,ptrsinttype),
  316. ctypeconvnode.create_internal(
  317. cnilnode.create,ptrsinttype)),
  318. ccallnode.create(nil,tprocsym(srsym),srsym.owner,load_self_node,[]),
  319. nil));
  320. end
  321. else
  322. internalerror(200305104);
  323. end;
  324. end;
  325. end;
  326. function generate_bodyexit_block:tnode;
  327. var
  328. srsym : tsym;
  329. para : tcallparanode;
  330. newstatement : tstatementnode;
  331. oldlocalswitches: tlocalswitches;
  332. begin
  333. result:=internalstatements(newstatement);
  334. if assigned(current_procinfo.procdef._class) then
  335. begin
  336. { Don't test self and the vmt here. The reason is that }
  337. { a constructor already checks whether these are valid }
  338. { before. Further, in case of TThread the thread may }
  339. { free the class instance right after AfterConstruction }
  340. { has been called, so it may no longer be valid (JM) }
  341. oldlocalswitches:=current_settings.localswitches;
  342. current_settings.localswitches:=oldlocalswitches-[cs_check_object,cs_check_range];
  343. { maybe call AfterConstruction for classes }
  344. if (current_procinfo.procdef.proctypeoption=potype_constructor) and
  345. is_class(current_procinfo.procdef._class) then
  346. begin
  347. srsym:=search_class_member(current_procinfo.procdef._class,'AFTERCONSTRUCTION');
  348. if assigned(srsym) and
  349. (srsym.typ=procsym) then
  350. begin
  351. { Self can be nil when fail is called }
  352. { if self<>nil and vmt<>nil then afterconstruction }
  353. addstatement(newstatement,cifnode.create(
  354. caddnode.create(andn,
  355. caddnode.create(unequaln,
  356. load_self_pointer_node,
  357. cnilnode.create),
  358. caddnode.create(unequaln,
  359. load_vmt_pointer_node,
  360. cnilnode.create)),
  361. ccallnode.create(nil,tprocsym(srsym),srsym.owner,load_self_node,[]),
  362. nil));
  363. end
  364. else
  365. internalerror(200305106);
  366. end;
  367. { a destructor needs a help procedure }
  368. if (current_procinfo.procdef.proctypeoption=potype_destructor) then
  369. begin
  370. if is_class(current_procinfo.procdef._class) then
  371. begin
  372. srsym:=search_class_member(current_procinfo.procdef._class,'FREEINSTANCE');
  373. if assigned(srsym) and
  374. (srsym.typ=procsym) then
  375. begin
  376. { if self<>0 and vmt<>0 then freeinstance }
  377. addstatement(newstatement,cifnode.create(
  378. caddnode.create(andn,
  379. caddnode.create(unequaln,
  380. load_self_pointer_node,
  381. cnilnode.create),
  382. caddnode.create(unequaln,
  383. ctypeconvnode.create(
  384. load_vmt_pointer_node,
  385. voidpointertype),
  386. cpointerconstnode.create(0,voidpointertype))),
  387. ccallnode.create(nil,tprocsym(srsym),srsym.owner,load_self_node,[]),
  388. nil));
  389. end
  390. else
  391. internalerror(200305108);
  392. end
  393. else
  394. if is_object(current_procinfo.procdef._class) then
  395. begin
  396. { finalize object data }
  397. if current_procinfo.procdef._class.needs_inittable then
  398. addstatement(newstatement,finalize_data_node(load_self_node));
  399. { parameter 3 : vmt_offset }
  400. { parameter 2 : pointer to vmt }
  401. { parameter 1 : self pointer }
  402. para:=ccallparanode.create(
  403. cordconstnode.create(current_procinfo.procdef._class.vmt_offset,s32inttype,false),
  404. ccallparanode.create(
  405. ctypeconvnode.create_internal(
  406. load_vmt_pointer_node,
  407. voidpointertype),
  408. ccallparanode.create(
  409. ctypeconvnode.create_internal(
  410. load_self_pointer_node,
  411. voidpointertype),
  412. nil)));
  413. addstatement(newstatement,
  414. ccallnode.createintern('fpc_help_destructor',para));
  415. end
  416. else
  417. internalerror(200305105);
  418. end;
  419. current_settings.localswitches:=oldlocalswitches;
  420. end;
  421. end;
  422. function generate_except_block:tnode;
  423. var
  424. pd : tprocdef;
  425. newstatement : tstatementnode;
  426. oldlocalswitches: tlocalswitches;
  427. begin
  428. generate_except_block:=internalstatements(newstatement);
  429. { a constructor needs call destructor (if available) when it
  430. is not inherited }
  431. if assigned(current_procinfo.procdef._class) and
  432. (current_procinfo.procdef.proctypeoption=potype_constructor) then
  433. begin
  434. { Don't test self and the vmt here. See generate_bodyexit_block }
  435. { why (JM) }
  436. oldlocalswitches:=current_settings.localswitches;
  437. current_settings.localswitches:=oldlocalswitches-[cs_check_object,cs_check_range];
  438. pd:=current_procinfo.procdef._class.Finddestructor;
  439. if assigned(pd) then
  440. begin
  441. { if vmt<>0 then call destructor }
  442. addstatement(newstatement,cifnode.create(
  443. caddnode.create(unequaln,
  444. load_vmt_pointer_node,
  445. cnilnode.create),
  446. { cnf_create_failed -> don't call BeforeDestruction }
  447. ccallnode.create(nil,tprocsym(pd.procsym),pd.procsym.owner,load_self_node,[cnf_create_failed]),
  448. nil));
  449. end;
  450. current_settings.localswitches:=oldlocalswitches;
  451. end
  452. else
  453. begin
  454. { no constructor }
  455. { must be the return value finalized before reraising the exception? }
  456. if (not is_void(current_procinfo.procdef.returndef)) and
  457. (current_procinfo.procdef.returndef.needs_inittable) and
  458. (not is_class(current_procinfo.procdef.returndef)) then
  459. addstatement(newstatement,finalize_data_node(load_result_node));
  460. end;
  461. end;
  462. {****************************************************************************
  463. TCGProcInfo
  464. ****************************************************************************}
  465. constructor tcgprocinfo.create(aparent:tprocinfo);
  466. begin
  467. inherited Create(aparent);
  468. nestedprocs:=tlinkedlist.create;
  469. end;
  470. destructor tcgprocinfo.destroy;
  471. begin
  472. nestedprocs.free;
  473. if assigned(code) then
  474. code.free;
  475. inherited destroy;
  476. end;
  477. procedure tcgprocinfo.printproc;
  478. begin
  479. assign(printnodefile,treelogfilename);
  480. {$I-}
  481. append(printnodefile);
  482. if ioresult<>0 then
  483. rewrite(printnodefile);
  484. {$I+}
  485. if ioresult<>0 then
  486. begin
  487. Comment(V_Error,'Error creating '+treelogfilename);
  488. exit;
  489. end;
  490. writeln(printnodefile);
  491. writeln(printnodefile,'*******************************************************************************');
  492. writeln(printnodefile,procdef.fullprocname(false));
  493. writeln(printnodefile,'*******************************************************************************');
  494. printnode(printnodefile,code);
  495. close(printnodefile);
  496. end;
  497. procedure tcgprocinfo.add_entry_exit_code;
  498. var
  499. finalcode,
  500. bodyentrycode,
  501. bodyexitcode,
  502. exceptcode : tnode;
  503. newblock : tblocknode;
  504. codestatement,
  505. newstatement : tstatementnode;
  506. oldfilepos : tfileposinfo;
  507. begin
  508. oldfilepos:=current_filepos;
  509. { Generate code/locations used at start of proc }
  510. current_filepos:=entrypos;
  511. entry_asmnode:=casmnode.create_get_position;
  512. loadpara_asmnode:=casmnode.create_get_position;
  513. stackcheck_asmnode:=casmnode.create_get_position;
  514. init_asmnode:=casmnode.create_get_position;
  515. bodyentrycode:=generate_bodyentry_block;
  516. { Generate code/locations used at end of proc }
  517. current_filepos:=exitpos;
  518. exitlabel_asmnode:=casmnode.create_get_position;
  519. final_asmnode:=casmnode.create_get_position;
  520. bodyexitcode:=generate_bodyexit_block;
  521. { Generate procedure by combining init+body+final,
  522. depending on the implicit finally we need to add
  523. an try...finally...end wrapper }
  524. newblock:=internalstatements(newstatement);
  525. if (cs_implicit_exceptions in current_settings.moduleswitches) and
  526. (pi_needs_implicit_finally in flags) and
  527. { but it's useless in init/final code of units }
  528. not(procdef.proctypeoption in [potype_unitfinalize,potype_unitinit]) then
  529. begin
  530. { Generate special exception block only needed when
  531. implicit finaly is used }
  532. current_filepos:=exitpos;
  533. exceptcode:=generate_except_block;
  534. { Generate code that will be in the try...finally }
  535. finalcode:=internalstatements(codestatement);
  536. addstatement(codestatement,final_asmnode);
  537. { Initialize before try...finally...end frame }
  538. addstatement(newstatement,loadpara_asmnode);
  539. addstatement(newstatement,stackcheck_asmnode);
  540. addstatement(newstatement,entry_asmnode);
  541. addstatement(newstatement,init_asmnode);
  542. addstatement(newstatement,bodyentrycode);
  543. current_filepos:=entrypos;
  544. addstatement(newstatement,ctryfinallynode.create_implicit(
  545. code,
  546. finalcode,
  547. exceptcode));
  548. addstatement(newstatement,exitlabel_asmnode);
  549. addstatement(newstatement,bodyexitcode);
  550. { set flag the implicit finally has been generated }
  551. include(flags,pi_has_implicit_finally);
  552. end
  553. else
  554. begin
  555. addstatement(newstatement,loadpara_asmnode);
  556. addstatement(newstatement,stackcheck_asmnode);
  557. addstatement(newstatement,entry_asmnode);
  558. addstatement(newstatement,init_asmnode);
  559. addstatement(newstatement,bodyentrycode);
  560. addstatement(newstatement,code);
  561. addstatement(newstatement,exitlabel_asmnode);
  562. addstatement(newstatement,bodyexitcode);
  563. addstatement(newstatement,final_asmnode);
  564. end;
  565. do_firstpass(newblock);
  566. code:=newblock;
  567. current_filepos:=oldfilepos;
  568. end;
  569. procedure clearrefs(p:TObject;arg:pointer);
  570. begin
  571. if (tsym(p).typ in [localvarsym,paravarsym,staticvarsym]) then
  572. if tabstractvarsym(p).refs>1 then
  573. tabstractvarsym(p).refs:=1;
  574. end;
  575. procedure translate_registers(p:TObject;list:pointer);
  576. begin
  577. if (tsym(p).typ in [localvarsym,paravarsym,staticvarsym]) and
  578. (tabstractnormalvarsym(p).localloc.loc in [LOC_REGISTER,LOC_CREGISTER,LOC_MMREGISTER,
  579. LOC_CMMREGISTER,LOC_FPUREGISTER,LOC_CFPUREGISTER]) then
  580. begin
  581. if not(cs_no_regalloc in current_settings.globalswitches) then
  582. cg.translate_register(tabstractnormalvarsym(p).localloc.register);
  583. if cs_asm_source in current_settings.globalswitches then
  584. TAsmList(list).concat(Tai_comment.Create(strpnew('Var '+tabstractnormalvarsym(p).realname+' located in register '+
  585. std_regname(tabstractnormalvarsym(p).localloc.register))))
  586. end;
  587. end;
  588. procedure check_for_stack(p:TObject;arg:pointer);
  589. begin
  590. if tsym(p).typ=paravarsym then
  591. begin
  592. { check if there no parameter of the current procedure is stack dependend }
  593. if is_open_array(tparavarsym(p).vardef) or
  594. is_array_of_const(tparavarsym(p).vardef) then
  595. pboolean(arg)^:=true;
  596. if assigned(p) and
  597. assigned(tparavarsym(p).paraloc[calleeside].location) and
  598. (tparavarsym(p).paraloc[calleeside].location^.loc=LOC_REFERENCE) then
  599. pboolean(arg)^:=true;
  600. end;
  601. end;
  602. function tcgprocinfo.stack_tainting_parameter : boolean;
  603. begin
  604. result:=false;
  605. procdef.parast.SymList.ForEachCall(@check_for_stack,@result);
  606. end;
  607. function tcgprocinfo.has_assembler_child : boolean;
  608. var
  609. hp : tcgprocinfo;
  610. begin
  611. result:=false;
  612. hp:=tcgprocinfo(nestedprocs.first);
  613. while assigned(hp) do
  614. begin
  615. if (hp.flags*[pi_has_assembler_block,pi_is_assembler])<>[] then
  616. begin
  617. result:=true;
  618. exit;
  619. end;
  620. hp:=tcgprocinfo(hp.next);
  621. end;
  622. end;
  623. procedure tcgprocinfo.generate_code;
  624. var
  625. oldprocinfo : tprocinfo;
  626. oldmaxfpuregisters : longint;
  627. oldfilepos : tfileposinfo;
  628. templist : TAsmList;
  629. headertai : tai;
  630. begin
  631. { the initialization procedure can be empty, then we
  632. don't need to generate anything. When it was an empty
  633. procedure there would be at least a blocknode }
  634. if not assigned(code) then
  635. exit;
  636. { We need valid code }
  637. if Errorcount<>0 then
  638. exit;
  639. { No code can be generated for generic template }
  640. if (df_generic in procdef.defoptions) then
  641. internalerror(200511152);
  642. { The RA and Tempgen shall not be available yet }
  643. if assigned(tg) then
  644. internalerror(200309201);
  645. oldprocinfo:=current_procinfo;
  646. oldfilepos:=current_filepos;
  647. oldmaxfpuregisters:=current_settings.maxfpuregisters;
  648. current_procinfo:=self;
  649. current_filepos:=entrypos;
  650. templist:=TAsmList.create;
  651. { add parast/localst to symtablestack }
  652. add_to_symtablestack;
  653. { when size optimization only count occurrence }
  654. if cs_opt_size in current_settings.optimizerswitches then
  655. cg.t_times:=1
  656. else
  657. { reference for repetition is 100 }
  658. cg.t_times:=100;
  659. { clear register count }
  660. procdef.localst.SymList.ForEachCall(@clearrefs,nil);
  661. procdef.parast.SymList.ForEachCall(@clearrefs,nil);
  662. { there's always a call to FPC_INITIALIZEUNITS/FPC_DO_EXIT in the main program }
  663. if (procdef.localst.symtablelevel=main_program_level) and
  664. (not current_module.is_unit) then
  665. include(flags,pi_do_call);
  666. { set implicit_finally flag when there are locals/paras to be finalized }
  667. procdef.parast.SymList.ForEachCall(@check_finalize_paras,nil);
  668. procdef.localst.SymList.ForEachCall(@check_finalize_locals,nil);
  669. { firstpass everything }
  670. flowcontrol:=[];
  671. do_firstpass(code);
  672. if code.registersfpu>0 then
  673. include(flags,pi_uses_fpu);
  674. { do this before adding the entry code else the tail recursion recognition won't work,
  675. if this causes troubles, it must be if'ed
  676. }
  677. if (cs_opt_tailrecursion in current_settings.optimizerswitches) and
  678. (pi_is_recursive in flags) then
  679. do_opttail(code,procdef);
  680. if cs_opt_nodedfa in current_settings.optimizerswitches then
  681. begin
  682. createdfainfo(code);
  683. end;
  684. if cs_opt_nodecse in current_settings.optimizerswitches then
  685. do_optcse(code);
  686. { add implicit entry and exit code }
  687. add_entry_exit_code;
  688. { only do secondpass if there are no errors }
  689. if (ErrorCount=0) then
  690. begin
  691. { set the start offset to the start of the temp area in the stack }
  692. tg:=ttgobj.create;
  693. {$if defined(x86) or defined(arm)}
  694. { try to strip the stack frame }
  695. { set the framepointer to esp if:
  696. - no assembler directive, those are handled in assembler_block
  697. in pstatment.pas (for cases not caught by the Delphi
  698. exception below)
  699. - no exceptions are used
  700. - no debug info
  701. - no pushes are used/esp modifications, could be:
  702. * outgoing parameters on the stack
  703. * incoming parameters on the stack
  704. * open arrays
  705. - no inline assembler
  706. or
  707. - Delphi mode
  708. - assembler directive
  709. - no pushes are used/esp modifications, could be:
  710. * outgoing parameters on the stack
  711. * incoming parameters on the stack
  712. * open arrays
  713. - no local variables
  714. }
  715. if ((po_assembler in procdef.procoptions) and
  716. (m_delphi in current_settings.modeswitches) and
  717. { localst at main_program_level is a staticsymtable }
  718. (procdef.localst.symtablelevel<>main_program_level) and
  719. (tabstractlocalsymtable(procdef.localst).count_locals = 0)) or
  720. ((cs_opt_stackframe in current_settings.optimizerswitches) and
  721. not(cs_generate_stackframes in current_settings.localswitches) and
  722. not(po_assembler in procdef.procoptions) and
  723. ((flags*[pi_has_assembler_block,pi_uses_exceptions,pi_is_assembler,
  724. pi_needs_implicit_finally,pi_has_implicit_finally,pi_has_stackparameter,
  725. pi_needs_stackframe])=[])
  726. {$ifdef arm}
  727. and ((cs_fp_emulation in current_settings.moduleswitches) or not (pi_uses_fpu in flags))
  728. {$endif arm}
  729. )
  730. then
  731. begin
  732. { we need the parameter info here to determine if the procedure gets
  733. parameters on the stack
  734. calling generate_parameter_info doesn't hurt but it costs time
  735. }
  736. generate_parameter_info;
  737. if not(stack_tainting_parameter) and
  738. not(has_assembler_child) and (para_stack_size=0) then
  739. begin
  740. { Only need to set the framepointer }
  741. framepointer:=NR_STACK_POINTER_REG;
  742. tg.direction:=1;
  743. end;
  744. end;
  745. {$endif}
  746. { Create register allocator }
  747. cg.init_register_allocators;
  748. set_first_temp_offset;
  749. generate_parameter_info;
  750. { Allocate space in temp/registers for parast and localst }
  751. current_filepos:=entrypos;
  752. gen_alloc_symtable(aktproccode,procdef.parast);
  753. gen_alloc_symtable(aktproccode,procdef.localst);
  754. { Store temp offset for information about 'real' temps }
  755. tempstart:=tg.lasttemp;
  756. { Generate code to load register parameters in temps and insert local
  757. copies for values parameters. This must be done before the code for the
  758. body is generated because the localloc is updated.
  759. Note: The generated code will be inserted after the code generation of
  760. the body is finished, because only then the position is known }
  761. {$ifdef oldregvars}
  762. assign_regvars(code);
  763. {$endif oldreg}
  764. current_filepos:=entrypos;
  765. { record which registers are allocated here, since all code }
  766. { allocating registers comes after it }
  767. cg.set_regalloc_extend_backwards(true);
  768. gen_load_para_value(templist);
  769. cg.set_regalloc_extend_backwards(false);
  770. { caller paraloc info is also necessary in the stackframe_entry
  771. code of the ppc (and possibly other processors) }
  772. if not procdef.has_paraloc_info then
  773. begin
  774. procdef.requiredargarea:=paramanager.create_paraloc_info(procdef,callerside);
  775. procdef.has_paraloc_info:=true;
  776. end;
  777. { generate code for the node tree }
  778. do_secondpass(code);
  779. aktproccode.concatlist(current_asmdata.CurrAsmList);
  780. {$ifdef i386}
  781. procdef.fpu_used:=code.registersfpu;
  782. {$endif i386}
  783. { The position of the loadpara_asmnode is now known }
  784. aktproccode.insertlistafter(loadpara_asmnode.currenttai,templist);
  785. { first generate entry and initialize code with the correct
  786. position and switches }
  787. current_filepos:=entrypos;
  788. current_settings.localswitches:=entryswitches;
  789. cg.set_regalloc_extend_backwards(true);
  790. gen_entry_code(templist);
  791. aktproccode.insertlistafter(entry_asmnode.currenttai,templist);
  792. gen_initialize_code(templist);
  793. aktproccode.insertlistafter(init_asmnode.currenttai,templist);
  794. { now generate finalize and exit code with the correct position
  795. and switches }
  796. current_filepos:=exitpos;
  797. current_settings.localswitches:=exitswitches;
  798. cg.set_regalloc_extend_backwards(false);
  799. gen_finalize_code(templist);
  800. { the finalcode must be concated if there was no position available,
  801. using insertlistafter will result in an insert at the start
  802. when currentai=nil }
  803. if assigned(final_asmnode.currenttai) then
  804. aktproccode.insertlistafter(final_asmnode.currenttai,templist)
  805. else
  806. aktproccode.concatlist(templist);
  807. { insert exit label at the correct position }
  808. cg.a_label(templist,CurrExitLabel);
  809. if assigned(exitlabel_asmnode.currenttai) then
  810. aktproccode.insertlistafter(exitlabel_asmnode.currenttai,templist)
  811. else
  812. aktproccode.concatlist(templist);
  813. { exit code }
  814. gen_exit_code(templist);
  815. aktproccode.concatlist(templist);
  816. {$ifdef OLDREGVARS}
  817. { note: this must be done only after as much code as possible has }
  818. { been generated. The result is that when you ungetregister() a }
  819. { regvar, it will actually free the regvar (and alse free the }
  820. { the regvars at the same time). Doing this too early will }
  821. { confuse the register allocator, as the regvars will still be }
  822. { used. It should be done before loading the result regs (so }
  823. { they don't conflict with the regvars) and before }
  824. { gen_entry_code (that one has to be able to allocate the }
  825. { regvars again) (JM) }
  826. free_regvars(aktproccode);
  827. {$endif OLDREGVARS}
  828. { generate symbol and save end of header position }
  829. current_filepos:=entrypos;
  830. gen_proc_symbol(templist);
  831. headertai:=tai(templist.last);
  832. { insert symbol }
  833. aktproccode.insertlist(templist);
  834. { Free space in temp/registers for parast and localst, must be
  835. done after gen_entry_code }
  836. current_filepos:=exitpos;
  837. gen_free_symtable(aktproccode,procdef.localst);
  838. gen_free_symtable(aktproccode,procdef.parast);
  839. { add code that will load the return value, this is not done
  840. for assembler routines when they didn't reference the result
  841. variable }
  842. gen_load_return_value(templist);
  843. aktproccode.concatlist(templist);
  844. { Already reserve all registers for stack checking code and
  845. generate the call to the helper function }
  846. if (cs_check_stack in entryswitches) and
  847. not(po_assembler in procdef.procoptions) and
  848. (procdef.proctypeoption<>potype_proginit) then
  849. begin
  850. current_filepos:=entrypos;
  851. gen_stack_check_call(templist);
  852. aktproccode.insertlistafter(stackcheck_asmnode.currenttai,templist)
  853. end;
  854. { load got if necessary }
  855. cg.set_regalloc_extend_backwards(true);
  856. current_filepos:=entrypos;
  857. gen_got_load(templist);
  858. aktproccode.insertlistafter(headertai,templist);
  859. cg.set_regalloc_extend_backwards(false);
  860. { The procedure body is finished, we can now
  861. allocate the registers }
  862. cg.do_register_allocation(aktproccode,headertai);
  863. { translate imag. register to their real counter parts
  864. this is necessary for debuginfo and verbose assembler output
  865. when SSA will be implented, this will be more complicated because we've to
  866. maintain location lists }
  867. current_procinfo.procdef.parast.SymList.ForEachCall(@translate_registers,templist);
  868. current_procinfo.procdef.localst.SymList.ForEachCall(@translate_registers,templist);
  869. { Add save and restore of used registers }
  870. current_filepos:=entrypos;
  871. gen_save_used_regs(templist);
  872. aktproccode.insertlistafter(headertai,templist);
  873. current_filepos:=exitpos;
  874. gen_restore_used_regs(aktproccode);
  875. { We know the size of the stack, now we can generate the
  876. parameter that is passed to the stack checking code }
  877. if (cs_check_stack in entryswitches) and
  878. not(po_assembler in procdef.procoptions) and
  879. (procdef.proctypeoption<>potype_proginit) then
  880. begin
  881. current_filepos:=entrypos;
  882. gen_stack_check_size_para(templist);
  883. aktproccode.insertlistafter(stackcheck_asmnode.currenttai,templist)
  884. end;
  885. { Add entry code (stack allocation) after header }
  886. current_filepos:=entrypos;
  887. gen_proc_entry_code(templist);
  888. aktproccode.insertlistafter(headertai,templist);
  889. { Add exit code at the end }
  890. current_filepos:=exitpos;
  891. gen_proc_exit_code(templist);
  892. aktproccode.concatlist(templist);
  893. { check if the implicit finally has been generated. The flag
  894. should already be set in pass1 }
  895. if (cs_implicit_exceptions in current_settings.moduleswitches) and
  896. not(procdef.proctypeoption in [potype_unitfinalize,potype_unitinit]) and
  897. (pi_needs_implicit_finally in flags) and
  898. not(pi_has_implicit_finally in flags) then
  899. internalerror(200405231);
  900. {$ifndef NoOpt}
  901. if not(cs_no_regalloc in current_settings.globalswitches) then
  902. begin
  903. if (cs_opt_level1 in current_settings.optimizerswitches) and
  904. { do not optimize pure assembler procedures }
  905. not(pi_is_assembler in flags) then
  906. optimize(aktproccode);
  907. end;
  908. {$endif NoOpt}
  909. {$ifdef ARM}
  910. { because of the limited constant size of the arm, all data access is done pc relative }
  911. insertpcrelativedata(aktproccode,aktlocaldata);
  912. {$endif ARM}
  913. { Add end symbol and debug info }
  914. { this must be done after the pcrelativedata is appended else the distance calculation of
  915. insertpcrelativedata will be wrong, further the pc indirect data is part of the procedure
  916. so it should be inserted before the end symbol (FK)
  917. }
  918. current_filepos:=exitpos;
  919. gen_proc_symbol_end(templist);
  920. aktproccode.concatlist(templist);
  921. {$if defined(POWERPC) or defined(POWERPC64)}
  922. fixup_jmps(aktproccode);
  923. {$endif}
  924. { insert line debuginfo }
  925. if (cs_debuginfo in current_settings.moduleswitches) or
  926. (cs_use_lineinfo in current_settings.globalswitches) then
  927. debuginfo.insertlineinfo(aktproccode);
  928. { add the procedure to the al_procedures }
  929. maybe_new_object_file(current_asmdata.asmlists[al_procedures]);
  930. new_section(current_asmdata.asmlists[al_procedures],sec_code,lower(procdef.mangledname),getprocalign);
  931. current_asmdata.asmlists[al_procedures].concatlist(aktproccode);
  932. { save local data (casetable) also in the same file }
  933. if assigned(aktlocaldata) and
  934. (not aktlocaldata.empty) then
  935. current_asmdata.asmlists[al_procedures].concatlist(aktlocaldata);
  936. { only now we can remove the temps }
  937. tg.resettempgen;
  938. { stop tempgen and ra }
  939. tg.free;
  940. cg.done_register_allocators;
  941. tg:=nil;
  942. end;
  943. { restore symtablestack }
  944. remove_from_symtablestack;
  945. { restore }
  946. templist.free;
  947. current_settings.maxfpuregisters:=oldmaxfpuregisters;
  948. current_filepos:=oldfilepos;
  949. current_procinfo:=oldprocinfo;
  950. end;
  951. procedure tcgprocinfo.add_to_symtablestack;
  952. var
  953. _class,hp : tobjectdef;
  954. begin
  955. { insert symtables for the class, but only if it is no nested function }
  956. if assigned(procdef._class) and
  957. not(assigned(parent) and
  958. assigned(parent.procdef) and
  959. assigned(parent.procdef._class)) then
  960. begin
  961. { insert them in the reverse order }
  962. hp:=nil;
  963. repeat
  964. _class:=procdef._class;
  965. while _class.childof<>hp do
  966. _class:=_class.childof;
  967. hp:=_class;
  968. symtablestack.push(_class.symtable);
  969. until hp=procdef._class;
  970. end;
  971. { insert parasymtable in symtablestack when parsing
  972. a function }
  973. if procdef.parast.symtablelevel>=normal_function_level then
  974. symtablestack.push(procdef.parast);
  975. { insert localsymtable }
  976. symtablestack.push(procdef.localst);
  977. end;
  978. procedure tcgprocinfo.remove_from_symtablestack;
  979. var
  980. _class : tobjectdef;
  981. begin
  982. { remove localsymtable }
  983. symtablestack.pop(procdef.localst);
  984. { remove parasymtable }
  985. if procdef.parast.symtablelevel>=normal_function_level then
  986. symtablestack.pop(procdef.parast);
  987. { remove symtables for the class, but only if it is no nested function }
  988. if assigned(procdef._class) and
  989. not(assigned(parent) and
  990. assigned(parent.procdef) and
  991. assigned(parent.procdef._class)) then
  992. begin
  993. _class:=procdef._class;
  994. while assigned(_class) do
  995. begin
  996. symtablestack.pop(_class.symtable);
  997. _class:=_class.childof;
  998. end;
  999. end;
  1000. end;
  1001. procedure tcgprocinfo.resetprocdef;
  1002. begin
  1003. { remove code tree, if not inline procedure }
  1004. if assigned(code) then
  1005. begin
  1006. { the inline procedure has already got a copy of the tree
  1007. stored in procdef.inlininginfo }
  1008. code.free;
  1009. code:=nil;
  1010. end;
  1011. end;
  1012. function checknodeinlining(procdef: tprocdef): boolean;
  1013. var
  1014. i : integer;
  1015. currpara : tparavarsym;
  1016. begin
  1017. result := false;
  1018. if (pi_has_assembler_block in current_procinfo.flags) then
  1019. exit;
  1020. for i:=0 to procdef.paras.count-1 do
  1021. begin
  1022. currpara:=tparavarsym(procdef.paras[i]);
  1023. { we can't handle formaldefs and special arrays (the latter may need a }
  1024. { re-basing of the index, i.e. if you pass an array[1..10] as open array, }
  1025. { you have to add 1 to all index operations if you directly inline it }
  1026. if ((currpara.varspez in [vs_out,vs_var,vs_const]) and
  1027. (currpara.vardef.typ=formaldef)) or
  1028. is_special_array(currpara.vardef) then
  1029. exit;
  1030. end;
  1031. result:=true;
  1032. end;
  1033. procedure tcgprocinfo.parse_body;
  1034. var
  1035. oldprocinfo : tprocinfo;
  1036. oldblock_type : tblock_type;
  1037. st : TSymtable;
  1038. begin
  1039. oldprocinfo:=current_procinfo;
  1040. oldblock_type:=block_type;
  1041. { reset break and continue labels }
  1042. block_type:=bt_body;
  1043. current_procinfo:=self;
  1044. { calculate the lexical level }
  1045. if procdef.parast.symtablelevel>maxnesting then
  1046. Message(parser_e_too_much_lexlevel);
  1047. {$ifdef state_tracking}
  1048. { aktstate:=Tstate_storage.create;}
  1049. {$endif state_tracking}
  1050. { allocate the symbol for this procedure }
  1051. alloc_proc_symbol(procdef);
  1052. { add parast/localst to symtablestack }
  1053. add_to_symtablestack;
  1054. { save entry info }
  1055. entrypos:=current_filepos;
  1056. entryswitches:=current_settings.localswitches;
  1057. if (df_generic in procdef.defoptions) then
  1058. begin
  1059. { start token recorder for generic template }
  1060. procdef.initgeneric;
  1061. current_scanner.startrecordtokens(procdef.generictokenbuf);
  1062. end;
  1063. { parse the code ... }
  1064. code:=block(current_module.islibrary);
  1065. if (df_generic in procdef.defoptions) then
  1066. begin
  1067. { stop token recorder for generic template }
  1068. current_scanner.stoprecordtokens;
  1069. { Give a warning for accesses in the static symtable that aren't visible
  1070. outside the current unit }
  1071. st:=procdef.owner;
  1072. while (st.symtabletype=ObjectSymtable) do
  1073. st:=st.defowner.owner;
  1074. if (pi_uses_static_symtable in flags) and
  1075. (st.symtabletype<>staticsymtable) then
  1076. Comment(V_Warning,'Global Generic template references static symtable');
  1077. end;
  1078. { save exit info }
  1079. exitswitches:=current_settings.localswitches;
  1080. exitpos:=last_endtoken_filepos;
  1081. { the procedure is now defined }
  1082. procdef.forwarddef:=false;
  1083. if assigned(code) then
  1084. begin
  1085. { get a better entry point }
  1086. entrypos:=code.fileinfo;
  1087. { Finish type checking pass }
  1088. do_typecheckpass(code);
  1089. end;
  1090. { Check for unused labels, forwards, symbols for procedures. Static
  1091. symtable is checked in pmodules.
  1092. The check must be done after the typecheckpass }
  1093. if (Errorcount=0) and
  1094. (tstoredsymtable(procdef.localst).symtabletype<>staticsymtable) then
  1095. begin
  1096. { check if forwards are resolved }
  1097. tstoredsymtable(procdef.localst).check_forwards;
  1098. { check if all labels are used }
  1099. tstoredsymtable(procdef.localst).checklabels;
  1100. { remove cross unit overloads }
  1101. tstoredsymtable(procdef.localst).unchain_overloaded;
  1102. { check for unused symbols, but only if there is no asm block }
  1103. if not(pi_has_assembler_block in flags) then
  1104. begin
  1105. tstoredsymtable(procdef.localst).allsymbolsused;
  1106. tstoredsymtable(procdef.parast).allsymbolsused;
  1107. end;
  1108. end;
  1109. if (po_inline in procdef.procoptions) then
  1110. begin
  1111. { Can we inline this procedure? }
  1112. if checknodeinlining(procdef) then
  1113. begin
  1114. new(procdef.inlininginfo);
  1115. include(procdef.procoptions,po_has_inlininginfo);
  1116. procdef.inlininginfo^.code:=code.getcopy;
  1117. procdef.inlininginfo^.flags:=current_procinfo.flags;
  1118. { The blocknode needs to set an exit label }
  1119. if procdef.inlininginfo^.code.nodetype=blockn then
  1120. include(procdef.inlininginfo^.code.flags,nf_block_with_exit);
  1121. end;
  1122. end;
  1123. { Print the node to tree.log }
  1124. if paraprintnodetree=1 then
  1125. printproc;
  1126. { ... remove symbol tables }
  1127. remove_from_symtablestack;
  1128. {$ifdef state_tracking}
  1129. { aktstate.destroy;}
  1130. {$endif state_tracking}
  1131. current_procinfo:=oldprocinfo;
  1132. { Restore old state }
  1133. block_type:=oldblock_type;
  1134. end;
  1135. {****************************************************************************
  1136. PROCEDURE/FUNCTION PARSING
  1137. ****************************************************************************}
  1138. procedure check_init_paras(p:TObject;arg:pointer);
  1139. begin
  1140. if tsym(p).typ<>paravarsym then
  1141. exit;
  1142. with tparavarsym(p) do
  1143. if (not is_class(vardef) and
  1144. vardef.needs_inittable and
  1145. (varspez in [vs_value,vs_out])) then
  1146. include(current_procinfo.flags,pi_do_call);
  1147. end;
  1148. procedure read_proc_body(old_current_procinfo:tprocinfo;pd:tprocdef);
  1149. {
  1150. Parses the procedure directives, then parses the procedure body, then
  1151. generates the code for it
  1152. }
  1153. procedure do_generate_code(pi:tcgprocinfo);
  1154. var
  1155. hpi : tcgprocinfo;
  1156. begin
  1157. { generate code for this procedure }
  1158. pi.generate_code;
  1159. { process nested procs }
  1160. hpi:=tcgprocinfo(pi.nestedprocs.first);
  1161. while assigned(hpi) do
  1162. begin
  1163. do_generate_code(hpi);
  1164. hpi:=tcgprocinfo(hpi.next);
  1165. end;
  1166. pi.resetprocdef;
  1167. end;
  1168. var
  1169. oldfailtokenmode : tmodeswitch;
  1170. isnestedproc : boolean;
  1171. begin
  1172. Message1(parser_d_procedure_start,pd.fullprocname(false));
  1173. { create a new procedure }
  1174. current_procinfo:=cprocinfo.create(old_current_procinfo);
  1175. current_module.procinfo:=current_procinfo;
  1176. current_procinfo.procdef:=pd;
  1177. isnestedproc:=(current_procinfo.procdef.parast.symtablelevel>normal_function_level);
  1178. { Insert mangledname }
  1179. pd.aliasnames.insert(pd.mangledname);
  1180. { Handle Export of this procedure }
  1181. if (po_exports in pd.procoptions) and
  1182. (target_info.system in [system_i386_os2,system_i386_emx]) then
  1183. begin
  1184. pd.aliasnames.insert(pd.procsym.realname);
  1185. if cs_link_deffile in current_settings.globalswitches then
  1186. deffile.AddExport(pd.mangledname);
  1187. end;
  1188. { Insert result variables in the localst }
  1189. insert_funcret_local(pd);
  1190. { check if there are para's which require initing -> set }
  1191. { pi_do_call (if not yet set) }
  1192. if not(pi_do_call in current_procinfo.flags) then
  1193. pd.parast.SymList.ForEachCall(@check_init_paras,nil);
  1194. { set _FAIL as keyword if constructor }
  1195. if (pd.proctypeoption=potype_constructor) then
  1196. begin
  1197. oldfailtokenmode:=tokeninfo^[_FAIL].keyword;
  1198. tokeninfo^[_FAIL].keyword:=m_all;
  1199. end;
  1200. tcgprocinfo(current_procinfo).parse_body;
  1201. { When it's a nested procedure then defer the code generation,
  1202. when back at normal function level then generate the code
  1203. for all defered nested procedures and the current procedure }
  1204. if isnestedproc then
  1205. tcgprocinfo(current_procinfo.parent).nestedprocs.insert(current_procinfo)
  1206. else
  1207. begin
  1208. { We can't support inlining for procedures that have nested
  1209. procedures because the nested procedures use a fixed offset
  1210. for accessing locals in the parent procedure (PFV) }
  1211. if (tcgprocinfo(current_procinfo).nestedprocs.count>0) then
  1212. begin
  1213. if (df_generic in current_procinfo.procdef.defoptions) then
  1214. Comment(V_Error,'Generic methods cannot have nested procedures')
  1215. else
  1216. if (po_inline in current_procinfo.procdef.procoptions) then
  1217. begin
  1218. Message1(parser_w_not_supported_for_inline,'nested procedures');
  1219. Message(parser_w_inlining_disabled);
  1220. current_procinfo.procdef.proccalloption:=pocall_default;
  1221. end;
  1222. end;
  1223. if not(df_generic in current_procinfo.procdef.defoptions) then
  1224. do_generate_code(tcgprocinfo(current_procinfo));
  1225. end;
  1226. { reset _FAIL as _SELF normal }
  1227. if (pd.proctypeoption=potype_constructor) then
  1228. tokeninfo^[_FAIL].keyword:=oldfailtokenmode;
  1229. { release procinfo }
  1230. if tprocinfo(current_module.procinfo)<>current_procinfo then
  1231. internalerror(200304274);
  1232. current_module.procinfo:=current_procinfo.parent;
  1233. { For specialization we didn't record the last semicolon. Moving this parsing
  1234. into the parse_body routine is not done because of having better file position
  1235. information available }
  1236. if not(df_specialization in current_procinfo.procdef.defoptions) then
  1237. consume(_SEMICOLON);
  1238. if not isnestedproc then
  1239. { current_procinfo is checked for nil later on }
  1240. freeandnil(current_procinfo);
  1241. end;
  1242. procedure read_proc;
  1243. {
  1244. Parses the procedure directives, then parses the procedure body, then
  1245. generates the code for it
  1246. }
  1247. procedure do_generate_code(pi:tcgprocinfo);
  1248. var
  1249. hpi : tcgprocinfo;
  1250. begin
  1251. { generate code for this procedure }
  1252. pi.generate_code;
  1253. { process nested procs }
  1254. hpi:=tcgprocinfo(pi.nestedprocs.first);
  1255. while assigned(hpi) do
  1256. begin
  1257. do_generate_code(hpi);
  1258. hpi:=tcgprocinfo(hpi.next);
  1259. end;
  1260. pi.resetprocdef;
  1261. end;
  1262. var
  1263. old_current_procinfo : tprocinfo;
  1264. pdflags : tpdflags;
  1265. pd,firstpd : tprocdef;
  1266. s : string;
  1267. begin
  1268. { save old state }
  1269. old_current_procinfo:=current_procinfo;
  1270. { reset current_procinfo.procdef to nil to be sure that nothing is writing
  1271. to an other procdef }
  1272. current_procinfo:=nil;
  1273. { parse procedure declaration }
  1274. if assigned(old_current_procinfo) and
  1275. assigned(old_current_procinfo.procdef) then
  1276. pd:=parse_proc_dec(old_current_procinfo.procdef._class)
  1277. else
  1278. pd:=parse_proc_dec(nil);
  1279. { set the default function options }
  1280. if parse_only then
  1281. begin
  1282. pd.forwarddef:=true;
  1283. { set also the interface flag, for better error message when the
  1284. implementation doesn't much this header }
  1285. pd.interfacedef:=true;
  1286. include(pd.procoptions,po_global);
  1287. pdflags:=[pd_interface];
  1288. end
  1289. else
  1290. begin
  1291. pdflags:=[pd_body];
  1292. if (not current_module.in_interface) then
  1293. include(pdflags,pd_implemen);
  1294. if (not current_module.is_unit) or
  1295. maybe_smartlink_symbol or
  1296. {
  1297. taking addresses of static procedures goes wrong
  1298. if they aren't global when pic is used (FK)
  1299. }
  1300. (cs_create_pic in current_settings.moduleswitches) then
  1301. include(pd.procoptions,po_global);
  1302. pd.forwarddef:=false;
  1303. end;
  1304. { parse the directives that may follow }
  1305. parse_proc_directives(pd,pdflags);
  1306. { hint directives, these can be separated by semicolons here,
  1307. that needs to be handled here with a loop (PFV) }
  1308. while try_consume_hintdirective(pd.symoptions) do
  1309. Consume(_SEMICOLON);
  1310. { Set calling convention }
  1311. handle_calling_convention(pd);
  1312. { search for forward declarations }
  1313. if not proc_add_definition(pd) then
  1314. begin
  1315. { A method must be forward defined (in the object declaration) }
  1316. if assigned(pd._class) and
  1317. (not assigned(old_current_procinfo.procdef._class)) then
  1318. begin
  1319. MessagePos1(pd.fileinfo,parser_e_header_dont_match_any_member,pd.fullprocname(false));
  1320. tprocsym(pd.procsym).write_parameter_lists(pd);
  1321. end
  1322. else
  1323. begin
  1324. { Give a better error if there is a forward def in the interface and only
  1325. a single implementation }
  1326. firstpd:=tprocdef(tprocsym(pd.procsym).ProcdefList[0]);
  1327. if (not pd.forwarddef) and
  1328. (not pd.interfacedef) and
  1329. (tprocsym(pd.procsym).ProcdefList.Count>1) and
  1330. firstpd.forwarddef and
  1331. firstpd.interfacedef and
  1332. not(tprocsym(pd.procsym).ProcdefList.Count>2) and
  1333. { don't give an error if it may be an overload }
  1334. not(m_fpc in current_settings.modeswitches) and
  1335. (not(po_overload in pd.procoptions) or
  1336. not(po_overload in firstpd.procoptions)) then
  1337. begin
  1338. MessagePos1(pd.fileinfo,parser_e_header_dont_match_forward,pd.fullprocname(false));
  1339. tprocsym(pd.procsym).write_parameter_lists(pd);
  1340. end;
  1341. end;
  1342. end;
  1343. { Set mangled name }
  1344. proc_set_mangledname(pd);
  1345. { compile procedure when a body is needed }
  1346. if (pd_body in pdflags) then
  1347. begin
  1348. read_proc_body(old_current_procinfo,pd);
  1349. end
  1350. else
  1351. begin
  1352. { Handle imports }
  1353. if (po_external in pd.procoptions) then
  1354. begin
  1355. { External declared in implementation, and there was already a
  1356. forward (or interface) declaration then we need to generate
  1357. a stub that calls the external routine }
  1358. if (not pd.forwarddef) and
  1359. (pd.hasforward) and
  1360. not(
  1361. assigned(pd.import_dll) and
  1362. (target_info.system in [system_i386_wdosx,
  1363. system_arm_wince,system_i386_wince])
  1364. ) then
  1365. begin
  1366. s:=proc_get_importname(pd);
  1367. if s<>'' then
  1368. gen_external_stub(current_asmdata.asmlists[al_procedures],pd,{$IFDEF POWERPC64}'.'+{$ENDIF}s);
  1369. end;
  1370. { Import DLL specified? }
  1371. if assigned(pd.import_dll) then
  1372. current_module.AddExternalImport(pd.import_dll^,proc_get_importname(pd),pd.import_nr,false)
  1373. else
  1374. begin
  1375. { add import name to external list for DLL scanning }
  1376. if tf_has_dllscanner in target_info.flags then
  1377. current_module.dllscannerinputlist.Add(proc_get_importname(pd),pd);
  1378. end;
  1379. end;
  1380. end;
  1381. { make sure that references to forward-declared functions are not }
  1382. { treated as references to external symbols, needed for darwin. }
  1383. { make sure we don't change the binding of real external symbols }
  1384. if not(po_external in pd.procoptions) then
  1385. begin
  1386. if (po_global in pd.procoptions) or
  1387. (cs_profile in current_settings.moduleswitches) then
  1388. current_asmdata.DefineAsmSymbol(pd.mangledname,AB_GLOBAL,AT_FUNCTION)
  1389. else
  1390. current_asmdata.DefineAsmSymbol(pd.mangledname,AB_LOCAL,AT_FUNCTION);
  1391. end;
  1392. current_procinfo:=old_current_procinfo;
  1393. end;
  1394. {****************************************************************************
  1395. DECLARATION PARSING
  1396. ****************************************************************************}
  1397. { search in symtablestack for not complete classes }
  1398. procedure check_forward_class(p:TObject;arg:pointer);
  1399. begin
  1400. if (tsym(p).typ=typesym) and
  1401. (ttypesym(p).typedef.typ=objectdef) and
  1402. (oo_is_forward in tobjectdef(ttypesym(p).typedef).objectoptions) then
  1403. MessagePos1(tsym(p).fileinfo,sym_e_forward_type_not_resolved,tsym(p).realname);
  1404. end;
  1405. procedure read_declarations(islibrary : boolean);
  1406. begin
  1407. repeat
  1408. if not assigned(current_procinfo) then
  1409. internalerror(200304251);
  1410. case token of
  1411. _LABEL:
  1412. label_dec;
  1413. _CONST:
  1414. const_dec;
  1415. _TYPE:
  1416. type_dec;
  1417. _VAR:
  1418. var_dec;
  1419. _THREADVAR:
  1420. threadvar_dec;
  1421. _CONSTRUCTOR,
  1422. _DESTRUCTOR,
  1423. _FUNCTION,
  1424. _PROCEDURE,
  1425. _OPERATOR,
  1426. _CLASS:
  1427. read_proc;
  1428. _EXPORTS:
  1429. begin
  1430. if (current_procinfo.procdef.localst.symtablelevel>main_program_level) then
  1431. begin
  1432. Message(parser_e_syntax_error);
  1433. consume_all_until(_SEMICOLON);
  1434. end
  1435. else if islibrary or
  1436. (target_info.system in system_unit_program_exports) then
  1437. read_exports
  1438. else
  1439. begin
  1440. Message(parser_w_unsupported_feature);
  1441. consume(_BEGIN);
  1442. end;
  1443. end
  1444. else
  1445. begin
  1446. case idtoken of
  1447. _RESOURCESTRING :
  1448. begin
  1449. { m_class is needed, because the resourcestring
  1450. loading is in the ObjPas unit }
  1451. { if (m_class in current_settings.modeswitches) then}
  1452. resourcestring_dec
  1453. { else
  1454. break;}
  1455. end;
  1456. _PROPERTY:
  1457. begin
  1458. if (m_fpc in current_settings.modeswitches) then
  1459. property_dec
  1460. else
  1461. break;
  1462. end;
  1463. else
  1464. break;
  1465. end;
  1466. end;
  1467. end;
  1468. until false;
  1469. { check for incomplete class definitions, this is only required
  1470. for fpc modes }
  1471. if (m_fpc in current_settings.modeswitches) then
  1472. current_procinfo.procdef.localst.SymList.ForEachCall(@check_forward_class,nil);
  1473. end;
  1474. procedure read_interface_declarations;
  1475. begin
  1476. repeat
  1477. case token of
  1478. _CONST :
  1479. const_dec;
  1480. _TYPE :
  1481. type_dec;
  1482. _VAR :
  1483. var_dec;
  1484. _THREADVAR :
  1485. threadvar_dec;
  1486. _FUNCTION,
  1487. _PROCEDURE,
  1488. _OPERATOR :
  1489. read_proc;
  1490. else
  1491. begin
  1492. case idtoken of
  1493. _RESOURCESTRING :
  1494. resourcestring_dec;
  1495. _PROPERTY:
  1496. begin
  1497. if (m_fpc in current_settings.modeswitches) then
  1498. property_dec
  1499. else
  1500. break;
  1501. end;
  1502. else
  1503. break;
  1504. end;
  1505. end;
  1506. end;
  1507. until false;
  1508. { check for incomplete class definitions, this is only required
  1509. for fpc modes }
  1510. if (m_fpc in current_settings.modeswitches) then
  1511. symtablestack.top.SymList.ForEachCall(@check_forward_class,nil);
  1512. end;
  1513. {****************************************************************************
  1514. SPECIALIZATION BODY GENERATION
  1515. ****************************************************************************}
  1516. procedure specialize_objectdefs(p:TObject;arg:pointer);
  1517. function find_module_from_symtable(st:tsymtable):tmodule;
  1518. var
  1519. hp : tmodule;
  1520. begin
  1521. result:=nil;
  1522. hp:=tmodule(loaded_units.first);
  1523. while assigned(hp) do
  1524. begin
  1525. if (hp.globalsymtable=st) or
  1526. (hp.localsymtable=st) then
  1527. begin
  1528. result:=hp;
  1529. exit;
  1530. end;
  1531. hp:=tmodule(hp.next);
  1532. end;
  1533. end;
  1534. var
  1535. i : longint;
  1536. hp : tdef;
  1537. oldcurrent_filepos : tfileposinfo;
  1538. oldsymtablestack : tsymtablestack;
  1539. pu : tused_unit;
  1540. hmodule : tmodule;
  1541. begin
  1542. if not((tsym(p).typ=typesym) and
  1543. (ttypesym(p).typedef.typ=objectdef) and
  1544. (df_specialization in ttypesym(p).typedef.defoptions)
  1545. ) then
  1546. exit;
  1547. { Setup symtablestack a definition time }
  1548. oldsymtablestack:=symtablestack;
  1549. symtablestack:=tsymtablestack.create;
  1550. if not assigned(tobjectdef(ttypesym(p).typedef).genericdef) then
  1551. internalerror(200705151);
  1552. hmodule:=find_module_from_symtable(tobjectdef(ttypesym(p).typedef).genericdef.owner);
  1553. if hmodule=nil then
  1554. internalerror(200705152);
  1555. pu:=tused_unit(hmodule.used_units.first);
  1556. while assigned(pu) do
  1557. begin
  1558. if not assigned(pu.u.globalsymtable) then
  1559. internalerror(200705153);
  1560. symtablestack.push(pu.u.globalsymtable);
  1561. pu:=tused_unit(pu.next);
  1562. end;
  1563. symtablestack.push(hmodule.globalsymtable);
  1564. symtablestack.push(hmodule.localsymtable);
  1565. { definitions }
  1566. for i:=0 to tobjectdef(ttypesym(p).typedef).symtable.DefList.Count-1 do
  1567. begin
  1568. hp:=tdef(tobjectdef(ttypesym(p).typedef).symtable.DefList[i]);
  1569. if hp.typ=procdef then
  1570. begin
  1571. if assigned(tprocdef(hp).genericdef) and
  1572. (tprocdef(hp).genericdef.typ=procdef) and
  1573. assigned(tprocdef(tprocdef(hp).genericdef).generictokenbuf) then
  1574. begin
  1575. oldcurrent_filepos:=current_filepos;
  1576. current_filepos:=tprocdef(tprocdef(hp).genericdef).fileinfo;
  1577. current_tokenpos:=current_filepos;
  1578. current_scanner.startreplaytokens(tprocdef(tprocdef(hp).genericdef).generictokenbuf);
  1579. read_proc_body(nil,tprocdef(hp));
  1580. current_filepos:=oldcurrent_filepos;
  1581. end
  1582. else
  1583. MessagePos1(tprocdef(tprocdef(hp).genericdef).fileinfo,sym_e_forward_not_resolved,tprocdef(tprocdef(hp).genericdef).fullprocname(false));
  1584. end;
  1585. end;
  1586. { Restore symtablestack }
  1587. symtablestack.free;
  1588. symtablestack:=oldsymtablestack;
  1589. end;
  1590. procedure generate_specialization_procs;
  1591. begin
  1592. if assigned(current_module.globalsymtable) then
  1593. current_module.globalsymtable.SymList.ForEachCall(@specialize_objectdefs,nil);
  1594. if assigned(current_module.localsymtable) then
  1595. current_module.localsymtable.SymList.ForEachCall(@specialize_objectdefs,nil);
  1596. end;
  1597. end.