psub.pas 107 KB

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