n386cal.pas 76 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752
  1. {
  2. $Id$
  3. Copyright (c) 1998-2000 by Florian Klaempfl
  4. Generate i386 assembler for in call nodes
  5. This program is free software; you can redistribute it and/or modify
  6. it under the terms of the GNU General Public License as published bymethodpointer
  7. the Free Software Foundation; either version 2 of the License, or
  8. (at your option) any later version.
  9. This program is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  12. GNU General Public License for more details.
  13. You should have received a copy of the GNU General Public License
  14. along with this program; if not, write to the Free Software
  15. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  16. ****************************************************************************
  17. }
  18. unit n386cal;
  19. {$i defines.inc}
  20. interface
  21. { $define AnsiStrRef}
  22. uses
  23. symdef,node,ncal;
  24. type
  25. ti386callparanode = class(tcallparanode)
  26. procedure secondcallparan(defcoll : TParaItem;
  27. push_from_left_to_right,inlined,is_cdecl : boolean;
  28. para_alignment,para_offset : longint);override;
  29. end;
  30. ti386callnode = class(tcallnode)
  31. procedure pass_2;override;
  32. end;
  33. ti386procinlinenode = class(tprocinlinenode)
  34. procedure pass_2;override;
  35. end;
  36. implementation
  37. uses
  38. {$ifdef delphi}
  39. sysutils,
  40. {$else}
  41. strings,
  42. {$endif}
  43. globtype,systems,
  44. cutils,verbose,globals,
  45. symconst,symbase,symsym,symtable,aasm,types,
  46. {$ifdef GDB}
  47. gdb,
  48. {$endif GDB}
  49. cgbase,temp_gen,pass_2,
  50. cpubase,cpuasm,
  51. nmem,nld,
  52. cga,tgcpu,n386ld,n386util,regvars;
  53. {*****************************************************************************
  54. TI386CALLPARANODE
  55. *****************************************************************************}
  56. procedure ti386callparanode.secondcallparan(defcoll : TParaItem;
  57. push_from_left_to_right,inlined,is_cdecl : boolean;para_alignment,para_offset : longint);
  58. procedure maybe_push_high;
  59. begin
  60. { open array ? }
  61. { defcoll.data can be nil for read/write }
  62. if assigned(defcoll.paratype.def) and
  63. assigned(hightree) then
  64. begin
  65. secondpass(hightree);
  66. { this is a longint anyway ! }
  67. push_value_para(hightree,inlined,false,para_offset,4);
  68. end;
  69. end;
  70. var
  71. otlabel,oflabel : tasmlabel;
  72. { temporary variables: }
  73. tempdeftype : tdeftype;
  74. r : preference;
  75. begin
  76. { set default para_alignment to target_info.stackalignment }
  77. if para_alignment=0 then
  78. para_alignment:=aktalignment.paraalign;
  79. { push from left to right if specified }
  80. if push_from_left_to_right and assigned(right) then
  81. begin
  82. if (nf_varargs_para in flags) then
  83. tcallparanode(right).secondcallparan(defcoll,push_from_left_to_right,
  84. inlined,is_cdecl,para_alignment,para_offset)
  85. else
  86. tcallparanode(right).secondcallparan(TParaItem(defcoll.next),push_from_left_to_right,
  87. inlined,is_cdecl,para_alignment,para_offset);
  88. end;
  89. otlabel:=truelabel;
  90. oflabel:=falselabel;
  91. getlabel(truelabel);
  92. getlabel(falselabel);
  93. secondpass(left);
  94. { handle varargs first, because defcoll is not valid }
  95. if (nf_varargs_para in flags) then
  96. begin
  97. if push_addr_param(left.resulttype.def) then
  98. begin
  99. inc(pushedparasize,4);
  100. emitpushreferenceaddr(left.location.reference);
  101. del_reference(left.location.reference);
  102. end
  103. else
  104. push_value_para(left,inlined,is_cdecl,para_offset,para_alignment);
  105. end
  106. { filter array constructor with c styled args }
  107. else if is_array_constructor(left.resulttype.def) and (nf_cargs in left.flags) then
  108. begin
  109. { nothing, everything is already pushed }
  110. end
  111. { in codegen.handleread.. defcoll.data is set to nil }
  112. else if assigned(defcoll.paratype.def) and
  113. (defcoll.paratype.def.deftype=formaldef) then
  114. begin
  115. { allow @var }
  116. inc(pushedparasize,4);
  117. if (left.nodetype=addrn) and
  118. (not(nf_procvarload in left.flags)) then
  119. begin
  120. { always a register }
  121. if inlined then
  122. begin
  123. r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize);
  124. emit_reg_ref(A_MOV,S_L,
  125. left.location.register,r);
  126. end
  127. else
  128. emit_reg(A_PUSH,S_L,left.location.register);
  129. ungetregister32(left.location.register);
  130. end
  131. else
  132. begin
  133. if not(left.location.loc in [LOC_MEM,LOC_REFERENCE]) then
  134. CGMessage(type_e_mismatch)
  135. else
  136. begin
  137. if inlined then
  138. begin
  139. getexplicitregister32(R_EDI);
  140. emit_ref_reg(A_LEA,S_L,
  141. newreference(left.location.reference),R_EDI);
  142. r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize);
  143. emit_reg_ref(A_MOV,S_L,R_EDI,r);
  144. ungetregister32(R_EDI);
  145. end
  146. else
  147. emitpushreferenceaddr(left.location.reference);
  148. del_reference(left.location.reference);
  149. end;
  150. end;
  151. end
  152. { handle call by reference parameter }
  153. else if (defcoll.paratyp in [vs_var,vs_out]) then
  154. begin
  155. if (left.location.loc<>LOC_REFERENCE) then
  156. internalerror(200106041);
  157. maybe_push_high;
  158. if (defcoll.paratyp=vs_out) and
  159. assigned(defcoll.paratype.def) and
  160. not is_class(defcoll.paratype.def) and
  161. defcoll.paratype.def.needs_inittable then
  162. finalize(defcoll.paratype.def,left.location.reference,false);
  163. inc(pushedparasize,4);
  164. if inlined then
  165. begin
  166. getexplicitregister32(R_EDI);
  167. emit_ref_reg(A_LEA,S_L,
  168. newreference(left.location.reference),R_EDI);
  169. r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize);
  170. emit_reg_ref(A_MOV,S_L,R_EDI,r);
  171. ungetregister32(R_EDI);
  172. end
  173. else
  174. emitpushreferenceaddr(left.location.reference);
  175. del_reference(left.location.reference);
  176. end
  177. else
  178. begin
  179. tempdeftype:=resulttype.def.deftype;
  180. if tempdeftype=filedef then
  181. CGMessage(cg_e_file_must_call_by_reference);
  182. { open array must always push the address, this is needed to
  183. also push addr of small open arrays and with cdecl functions (PFV) }
  184. if (
  185. assigned(defcoll.paratype.def) and
  186. (is_open_array(defcoll.paratype.def) or
  187. is_array_of_const(defcoll.paratype.def))
  188. ) or
  189. (
  190. push_addr_param(resulttype.def) and
  191. not is_cdecl
  192. ) then
  193. begin
  194. maybe_push_high;
  195. inc(pushedparasize,4);
  196. if inlined then
  197. begin
  198. getexplicitregister32(R_EDI);
  199. emit_ref_reg(A_LEA,S_L,
  200. newreference(left.location.reference),R_EDI);
  201. r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize);
  202. emit_reg_ref(A_MOV,S_L,R_EDI,r);
  203. ungetregister32(R_EDI);
  204. end
  205. else
  206. emitpushreferenceaddr(left.location.reference);
  207. del_reference(left.location.reference);
  208. end
  209. else
  210. begin
  211. push_value_para(left,inlined,is_cdecl,
  212. para_offset,para_alignment);
  213. end;
  214. end;
  215. truelabel:=otlabel;
  216. falselabel:=oflabel;
  217. { push from right to left }
  218. if not push_from_left_to_right and assigned(right) then
  219. begin
  220. if (nf_varargs_para in flags) then
  221. tcallparanode(right).secondcallparan(defcoll,push_from_left_to_right,
  222. inlined,is_cdecl,para_alignment,para_offset)
  223. else
  224. tcallparanode(right).secondcallparan(TParaItem(defcoll.next),push_from_left_to_right,
  225. inlined,is_cdecl,para_alignment,para_offset);
  226. end;
  227. end;
  228. {*****************************************************************************
  229. TI386CALLNODE
  230. *****************************************************************************}
  231. procedure ti386callnode.pass_2;
  232. var
  233. unusedregisters : tregisterset;
  234. usablecount : byte;
  235. pushed : tpushed;
  236. hr,funcretref : treference;
  237. hregister,hregister2 : tregister;
  238. oldpushedparasize : longint;
  239. { true if ESI must be loaded again after the subroutine }
  240. loadesi : boolean;
  241. { true if a virtual method must be called directly }
  242. no_virtual_call : boolean;
  243. { true if we produce a con- or destrutor in a call }
  244. is_con_or_destructor : boolean;
  245. { true if a constructor is called again }
  246. extended_new : boolean;
  247. { adress returned from an I/O-error }
  248. iolabel : tasmlabel;
  249. { lexlevel count }
  250. i : longint;
  251. { help reference pointer }
  252. r : preference;
  253. hp : tnode;
  254. pp : tbinarynode;
  255. params : tnode;
  256. inlined : boolean;
  257. inlinecode : tprocinlinenode;
  258. store_parast_fixup,
  259. para_alignment,
  260. para_offset : longint;
  261. { instruction for alignement correction }
  262. { corr : paicpu;}
  263. { we must pop this size also after !! }
  264. { must_pop : boolean; }
  265. pop_size : longint;
  266. {$ifdef OPTALIGN}
  267. pop_esp : boolean;
  268. push_size : longint;
  269. {$endif OPTALIGN}
  270. pop_allowed : boolean;
  271. regs_to_push : byte;
  272. constructorfailed : tasmlabel;
  273. label
  274. dont_call;
  275. begin
  276. reset_reference(location.reference);
  277. extended_new:=false;
  278. iolabel:=nil;
  279. inlinecode:=nil;
  280. inlined:=false;
  281. loadesi:=true;
  282. no_virtual_call:=false;
  283. unusedregisters:=unused;
  284. usablecount:=usablereg32;
  285. if (procdefinition.proccalloption in [pocall_cdecl,pocall_cppdecl,pocall_stdcall]) then
  286. para_alignment:=4
  287. else
  288. para_alignment:=aktalignment.paraalign;
  289. if not assigned(procdefinition) then
  290. exit;
  291. { Deciding whether we may still need the parameters happens next (JM) }
  292. if assigned(left) then
  293. params:=left.getcopy
  294. else params := nil;
  295. if (procdefinition.proccalloption=pocall_inline) then
  296. begin
  297. inlined:=true;
  298. inlinecode:=tprocinlinenode(right);
  299. right:=nil;
  300. { set it to the same lexical level as the local symtable, becuase
  301. the para's are stored there }
  302. tprocdef(procdefinition).parast.symtablelevel:=aktprocdef.localst.symtablelevel;
  303. if assigned(params) then
  304. inlinecode.para_offset:=gettempofsizepersistant(inlinecode.para_size);
  305. store_parast_fixup:=tprocdef(procdefinition).parast.address_fixup;
  306. tprocdef(procdefinition).parast.address_fixup:=inlinecode.para_offset;
  307. {$ifdef extdebug}
  308. Comment(V_debug,
  309. 'inlined parasymtable is at offset '
  310. +tostr(tprocdef(procdefinition).parast.address_fixup));
  311. exprasmList.concat(Tai_asm_comment.Create(
  312. strpnew('inlined parasymtable is at offset '
  313. +tostr(tprocdef(procdefinition).parast.address_fixup))));
  314. {$endif extdebug}
  315. end;
  316. { only if no proc var }
  317. if inlined or
  318. not(assigned(right)) then
  319. is_con_or_destructor:=(procdefinition.proctypeoption in [potype_constructor,potype_destructor]);
  320. { proc variables destroy all registers }
  321. if (inlined or
  322. (right=nil)) and
  323. { virtual methods too }
  324. not(po_virtualmethod in procdefinition.procoptions) then
  325. begin
  326. if (cs_check_io in aktlocalswitches) and
  327. (po_iocheck in procdefinition.procoptions) and
  328. not(po_iocheck in aktprocdef.procoptions) then
  329. begin
  330. getaddrlabel(iolabel);
  331. emitlab(iolabel);
  332. end
  333. else
  334. iolabel:=nil;
  335. { save all used registers }
  336. regs_to_push := tprocdef(procdefinition).usedregisters;
  337. pushusedregisters(pushed,regs_to_push);
  338. { give used registers through }
  339. usedinproc:=usedinproc or tprocdef(procdefinition).usedregisters;
  340. end
  341. else
  342. begin
  343. regs_to_push := $ff;
  344. pushusedregisters(pushed,regs_to_push);
  345. usedinproc:=$ff;
  346. { no IO check for methods and procedure variables }
  347. iolabel:=nil;
  348. end;
  349. { generate the code for the parameter and push them }
  350. oldpushedparasize:=pushedparasize;
  351. pushedparasize:=0;
  352. pop_size:=0;
  353. { no inc esp for inlined procedure
  354. and for objects constructors PM }
  355. if inlined or
  356. ((procdefinition.proctypeoption=potype_constructor) and
  357. { quick'n'dirty check if it is a class or an object }
  358. (resulttype.def.deftype=orddef)) then
  359. pop_allowed:=false
  360. else
  361. pop_allowed:=true;
  362. if pop_allowed then
  363. begin
  364. { Old pushedsize aligned on 4 ? }
  365. i:=oldpushedparasize and 3;
  366. if i>0 then
  367. inc(pop_size,4-i);
  368. { This parasize aligned on 4 ? }
  369. i:=procdefinition.para_size(para_alignment) and 3;
  370. if i>0 then
  371. inc(pop_size,4-i);
  372. { insert the opcode and update pushedparasize }
  373. { never push 4 or more !! }
  374. pop_size:=pop_size mod 4;
  375. if pop_size>0 then
  376. begin
  377. inc(pushedparasize,pop_size);
  378. emit_const_reg(A_SUB,S_L,pop_size,R_ESP);
  379. {$ifdef GDB}
  380. if (cs_debuginfo in aktmoduleswitches) and
  381. (exprasmList.first=exprasmList.last) then
  382. exprasmList.concat(Tai_force_line.Create);
  383. {$endif GDB}
  384. end;
  385. end;
  386. {$ifdef OPTALIGN}
  387. if pop_allowed and (cs_align in aktglobalswitches) then
  388. begin
  389. pop_esp:=true;
  390. push_size:=procdefinition.para_size(para_alignment);
  391. { !!!! here we have to take care of return type, self
  392. and nested procedures
  393. }
  394. inc(push_size,12);
  395. emit_reg_reg(A_MOV,S_L,R_ESP,R_EDI);
  396. if (push_size mod 8)=0 then
  397. emit_const_reg(A_AND,S_L,$fffffff8,R_ESP)
  398. else
  399. begin
  400. emit_const_reg(A_SUB,S_L,push_size,R_ESP);
  401. emit_const_reg(A_AND,S_L,$fffffff8,R_ESP);
  402. emit_const_reg(A_SUB,S_L,push_size,R_ESP);
  403. end;
  404. emit_reg(A_PUSH,S_L,R_EDI);
  405. end
  406. else
  407. pop_esp:=false;
  408. {$endif OPTALIGN}
  409. if (not is_void(resulttype.def)) and
  410. ret_in_param(resulttype.def) then
  411. begin
  412. funcretref.symbol:=nil;
  413. {$ifdef test_dest_loc}
  414. if dest_loc_known and (dest_loc_tree=p) and
  415. (dest_loc.loc in [LOC_REFERENCE,LOC_MEM]) then
  416. begin
  417. funcretref:=dest_loc.reference;
  418. if assigned(dest_loc.reference.symbol) then
  419. funcretref.symbol:=stringdup(dest_loc.reference.symbol^);
  420. in_dest_loc:=true;
  421. end
  422. else
  423. {$endif test_dest_loc}
  424. if inlined then
  425. begin
  426. reset_reference(funcretref);
  427. funcretref.offset:=gettempofsizepersistant(resulttype.def.size);
  428. funcretref.base:=procinfo^.framepointer;
  429. {$ifdef extdebug}
  430. Comment(V_debug,'function return value is at offset '
  431. +tostr(funcretref.offset));
  432. exprasmlist.concat(tai_asm_comment.create(
  433. strpnew('function return value is at offset '
  434. +tostr(funcretref.offset))));
  435. {$endif extdebug}
  436. end
  437. else
  438. gettempofsizereference(resulttype.def.size,funcretref);
  439. end;
  440. if assigned(params) then
  441. begin
  442. { be found elsewhere }
  443. if inlined then
  444. para_offset:=tprocdef(procdefinition).parast.address_fixup+
  445. tprocdef(procdefinition).parast.datasize
  446. else
  447. para_offset:=0;
  448. if not(inlined) and
  449. assigned(right) then
  450. tcallparanode(params).secondcallparan(TParaItem(tabstractprocdef(right.resulttype.def).Para.first),
  451. (po_leftright in procdefinition.procoptions),inlined,
  452. (procdefinition.proccalloption in [pocall_cdecl,pocall_cppdecl]),
  453. para_alignment,para_offset)
  454. else
  455. tcallparanode(params).secondcallparan(TParaItem(procdefinition.Para.first),
  456. (po_leftright in procdefinition.procoptions),inlined,
  457. (procdefinition.proccalloption in [pocall_cdecl,pocall_cppdecl]),
  458. para_alignment,para_offset);
  459. end;
  460. if inlined then
  461. inlinecode.retoffset:=gettempofsizepersistant(Align(resulttype.def.size,aktalignment.paraalign));
  462. if ret_in_param(resulttype.def) then
  463. begin
  464. { This must not be counted for C code
  465. complex return address is removed from stack
  466. by function itself ! }
  467. {$ifdef OLD_C_STACK}
  468. inc(pushedparasize,4); { lets try without it PM }
  469. {$endif not OLD_C_STACK}
  470. if inlined then
  471. begin
  472. getexplicitregister32(R_EDI);
  473. emit_ref_reg(A_LEA,S_L,
  474. newreference(funcretref),R_EDI);
  475. r:=new_reference(procinfo^.framepointer,inlinecode.retoffset);
  476. emit_reg_ref(A_MOV,S_L,R_EDI,r);
  477. ungetregister32(R_EDI);
  478. end
  479. else
  480. emitpushreferenceaddr(funcretref);
  481. end;
  482. { procedure variable ? }
  483. if inlined or
  484. (right=nil) then
  485. begin
  486. { overloaded operator has no symtable }
  487. { push self }
  488. if assigned(symtableproc) and
  489. (symtableproc.symtabletype=withsymtable) then
  490. begin
  491. { dirty trick to avoid the secondcall below }
  492. methodpointer:=ccallparanode.create(nil,nil);
  493. methodpointer.location.loc:=LOC_REGISTER;
  494. getexplicitregister32(R_ESI);
  495. methodpointer.location.register:=R_ESI;
  496. { ARGHHH this is wrong !!!
  497. if we can init from base class for a child
  498. class that the wrong VMT will be
  499. transfered to constructor !! }
  500. methodpointer.resulttype:=
  501. twithnode(twithsymtable(symtableproc).withnode).left.resulttype;
  502. { make a reference }
  503. new(r);
  504. reset_reference(r^);
  505. { if assigned(ptree(twithsymtable(symtable).withnode)^.pref) then
  506. begin
  507. r^:=ptree(twithsymtable(symtable).withnode)^.pref^;
  508. end
  509. else
  510. begin
  511. r^.offset:=symtable.datasize;
  512. r^.base:=procinfo^.framepointer;
  513. end; }
  514. r^:=twithnode(twithsymtable(symtableproc).withnode).withreference^;
  515. if ((not(nf_islocal in twithnode(twithsymtable(symtableproc).withnode).flags)) and
  516. (not twithsymtable(symtableproc).direct_with)) or
  517. is_class_or_interface(methodpointer.resulttype.def) then
  518. emit_ref_reg(A_MOV,S_L,r,R_ESI)
  519. else
  520. emit_ref_reg(A_LEA,S_L,r,R_ESI);
  521. end;
  522. { push self }
  523. if assigned(symtableproc) and
  524. ((symtableproc.symtabletype=objectsymtable) or
  525. (symtableproc.symtabletype=withsymtable)) then
  526. begin
  527. if assigned(methodpointer) then
  528. begin
  529. {
  530. if methodpointer^.resulttype.def=classrefdef then
  531. begin
  532. two possibilities:
  533. 1. constructor
  534. 2. class method
  535. end
  536. else }
  537. begin
  538. case methodpointer.nodetype of
  539. typen:
  540. begin
  541. { direct call to inherited method }
  542. if (po_abstractmethod in procdefinition.procoptions) then
  543. begin
  544. CGMessage(cg_e_cant_call_abstract_method);
  545. goto dont_call;
  546. end;
  547. { generate no virtual call }
  548. no_virtual_call:=true;
  549. if (sp_static in symtableprocentry.symoptions) then
  550. begin
  551. { well lets put the VMT address directly into ESI }
  552. { it is kind of dirty but that is the simplest }
  553. { way to accept virtual static functions (PM) }
  554. loadesi:=true;
  555. { if no VMT just use $0 bug0214 PM }
  556. getexplicitregister32(R_ESI);
  557. if not(oo_has_vmt in tobjectdef(methodpointer.resulttype.def).objectoptions) then
  558. emit_const_reg(A_MOV,S_L,0,R_ESI)
  559. else
  560. begin
  561. emit_sym_ofs_reg(A_MOV,S_L,
  562. newasmsymbol(tobjectdef(methodpointer.resulttype.def).vmt_mangledname),
  563. 0,R_ESI);
  564. end;
  565. { emit_reg(A_PUSH,S_L,R_ESI);
  566. this is done below !! }
  567. end
  568. else
  569. { this is a member call, so ESI isn't modfied }
  570. loadesi:=false;
  571. { a class destructor needs a flag }
  572. if is_class(tobjectdef(methodpointer.resulttype.def)) and
  573. (procdefinition.proctypeoption=potype_destructor) then
  574. begin
  575. push_int(0);
  576. emit_reg(A_PUSH,S_L,R_ESI);
  577. end;
  578. if not(is_con_or_destructor and
  579. is_class(methodpointer.resulttype.def) and
  580. (procdefinition.proctypeoption in [potype_constructor,potype_destructor])
  581. ) then
  582. emit_reg(A_PUSH,S_L,R_ESI);
  583. { if an inherited con- or destructor should be }
  584. { called in a con- or destructor then a warning }
  585. { will be made }
  586. { con- and destructors need a pointer to the vmt }
  587. if is_con_or_destructor and
  588. is_object(methodpointer.resulttype.def) and
  589. assigned(aktprocdef) then
  590. begin
  591. if not(aktprocdef.proctypeoption in
  592. [potype_constructor,potype_destructor]) then
  593. CGMessage(cg_w_member_cd_call_from_method);
  594. end;
  595. { class destructors get there flag above }
  596. { constructor flags ? }
  597. if is_con_or_destructor and
  598. not(
  599. is_class(methodpointer.resulttype.def) and
  600. assigned(aktprocdef) and
  601. (aktprocdef.proctypeoption=potype_destructor)) then
  602. begin
  603. { a constructor needs also a flag }
  604. if is_class(methodpointer.resulttype.def) then
  605. push_int(0);
  606. push_int(0);
  607. end;
  608. end;
  609. hnewn:
  610. begin
  611. { extended syntax of new }
  612. { ESI must be zero }
  613. getexplicitregister32(R_ESI);
  614. emit_reg_reg(A_XOR,S_L,R_ESI,R_ESI);
  615. emit_reg(A_PUSH,S_L,R_ESI);
  616. { insert the vmt }
  617. emit_sym(A_PUSH,S_L,
  618. newasmsymbol(tobjectdef(methodpointer.resulttype.def).vmt_mangledname));
  619. extended_new:=true;
  620. end;
  621. hdisposen:
  622. begin
  623. secondpass(methodpointer);
  624. { destructor with extended syntax called from dispose }
  625. { hdisposen always deliver LOC_REFERENCE }
  626. getexplicitregister32(R_ESI);
  627. emit_ref_reg(A_LEA,S_L,
  628. newreference(methodpointer.location.reference),R_ESI);
  629. del_reference(methodpointer.location.reference);
  630. emit_reg(A_PUSH,S_L,R_ESI);
  631. emit_sym(A_PUSH,S_L,
  632. newasmsymbol(tobjectdef(methodpointer.resulttype.def).vmt_mangledname));
  633. end;
  634. else
  635. begin
  636. { call to an instance member }
  637. if (symtableproc.symtabletype<>withsymtable) then
  638. begin
  639. secondpass(methodpointer);
  640. getexplicitregister32(R_ESI);
  641. case methodpointer.location.loc of
  642. LOC_CREGISTER,
  643. LOC_REGISTER:
  644. begin
  645. emit_reg_reg(A_MOV,S_L,methodpointer.location.register,R_ESI);
  646. ungetregister32(methodpointer.location.register);
  647. end;
  648. else
  649. begin
  650. if (methodpointer.resulttype.def.deftype=classrefdef) or
  651. is_class_or_interface(methodpointer.resulttype.def) then
  652. emit_ref_reg(A_MOV,S_L,
  653. newreference(methodpointer.location.reference),R_ESI)
  654. else
  655. emit_ref_reg(A_LEA,S_L,
  656. newreference(methodpointer.location.reference),R_ESI);
  657. del_reference(methodpointer.location.reference);
  658. end;
  659. end;
  660. end;
  661. { when calling a class method, we have to load ESI with the VMT !
  662. But, not for a class method via self }
  663. if not(po_containsself in procdefinition.procoptions) then
  664. begin
  665. if (po_classmethod in procdefinition.procoptions) and
  666. not(methodpointer.resulttype.def.deftype=classrefdef) then
  667. begin
  668. { class method needs current VMT }
  669. getexplicitregister32(R_ESI);
  670. new(r);
  671. reset_reference(r^);
  672. r^.base:=R_ESI;
  673. r^.offset:= tprocdef(procdefinition)._class.vmt_offset;
  674. emit_ref_reg(A_MOV,S_L,r,R_ESI);
  675. end;
  676. { direct call to destructor: remove data }
  677. if (procdefinition.proctypeoption=potype_destructor) and
  678. is_class(methodpointer.resulttype.def) then
  679. emit_const(A_PUSH,S_L,1);
  680. { direct call to class constructor, don't allocate memory }
  681. if (procdefinition.proctypeoption=potype_constructor) and
  682. is_class(methodpointer.resulttype.def) then
  683. begin
  684. emit_const(A_PUSH,S_L,0);
  685. emit_const(A_PUSH,S_L,0);
  686. end
  687. else
  688. begin
  689. { constructor call via classreference => allocate memory }
  690. if (procdefinition.proctypeoption=potype_constructor) and
  691. (methodpointer.resulttype.def.deftype=classrefdef) and
  692. is_class(tclassrefdef(methodpointer.resulttype.def).pointertype.def) then
  693. emit_const(A_PUSH,S_L,1);
  694. emit_reg(A_PUSH,S_L,R_ESI);
  695. end;
  696. end;
  697. if is_con_or_destructor then
  698. begin
  699. { classes don't get a VMT pointer pushed }
  700. if is_object(methodpointer.resulttype.def) then
  701. begin
  702. if (procdefinition.proctypeoption=potype_constructor) then
  703. begin
  704. { it's no bad idea, to insert the VMT }
  705. emit_sym(A_PUSH,S_L,newasmsymbol(
  706. tobjectdef(methodpointer.resulttype.def).vmt_mangledname));
  707. end
  708. { destructors haven't to dispose the instance, if this is }
  709. { a direct call }
  710. else
  711. push_int(0);
  712. end;
  713. end;
  714. end;
  715. end;
  716. end;
  717. end
  718. else
  719. begin
  720. if (po_classmethod in procdefinition.procoptions) and
  721. not(
  722. assigned(aktprocdef) and
  723. (po_classmethod in aktprocdef.procoptions)
  724. ) then
  725. begin
  726. { class method needs current VMT }
  727. getexplicitregister32(R_ESI);
  728. new(r);
  729. reset_reference(r^);
  730. r^.base:=R_ESI;
  731. r^.offset:= tprocdef(procdefinition)._class.vmt_offset;
  732. emit_ref_reg(A_MOV,S_L,r,R_ESI);
  733. end
  734. else
  735. begin
  736. { member call, ESI isn't modified }
  737. loadesi:=false;
  738. end;
  739. { direct call to destructor: don't remove data! }
  740. if is_class(procinfo^._class) then
  741. begin
  742. if (procdefinition.proctypeoption=potype_destructor) then
  743. begin
  744. emit_const(A_PUSH,S_L,0);
  745. emit_reg(A_PUSH,S_L,R_ESI);
  746. end
  747. else if (procdefinition.proctypeoption=potype_constructor) then
  748. begin
  749. emit_const(A_PUSH,S_L,0);
  750. emit_const(A_PUSH,S_L,0);
  751. end
  752. else
  753. emit_reg(A_PUSH,S_L,R_ESI);
  754. end
  755. else if is_object(procinfo^._class) then
  756. begin
  757. emit_reg(A_PUSH,S_L,R_ESI);
  758. if is_con_or_destructor then
  759. begin
  760. if (procdefinition.proctypeoption=potype_constructor) then
  761. begin
  762. { it's no bad idea, to insert the VMT }
  763. emit_sym(A_PUSH,S_L,newasmsymbol(
  764. procinfo^._class.vmt_mangledname));
  765. end
  766. { destructors haven't to dispose the instance, if this is }
  767. { a direct call }
  768. else
  769. push_int(0);
  770. end;
  771. end
  772. else
  773. Internalerror(200006165);
  774. end;
  775. end;
  776. { call to BeforeDestruction? }
  777. if (procdefinition.proctypeoption=potype_destructor) and
  778. assigned(methodpointer) and
  779. (methodpointer.nodetype<>typen) and
  780. is_class(tobjectdef(methodpointer.resulttype.def)) and
  781. (inlined or
  782. (right=nil)) then
  783. begin
  784. emit_reg(A_PUSH,S_L,R_ESI);
  785. new(r);
  786. reset_reference(r^);
  787. r^.base:=R_ESI;
  788. getexplicitregister32(R_EDI);
  789. emit_ref_reg(A_MOV,S_L,r,R_EDI);
  790. new(r);
  791. reset_reference(r^);
  792. r^.offset:=72;
  793. r^.base:=R_EDI;
  794. emit_ref(A_CALL,S_NO,r);
  795. ungetregister32(R_EDI);
  796. end;
  797. { push base pointer ?}
  798. { never when inlining, since if necessary, the base pointer }
  799. { can/will be gottten from the current procedure's symtable }
  800. { (JM) }
  801. if not inlined then
  802. if (lexlevel>=normal_function_level) and assigned(tprocdef(procdefinition).parast) and
  803. ((tprocdef(procdefinition).parast.symtablelevel)>normal_function_level) then
  804. begin
  805. { if we call a nested function in a method, we must }
  806. { push also SELF! }
  807. { THAT'S NOT TRUE, we have to load ESI via frame pointer }
  808. { access }
  809. {
  810. begin
  811. loadesi:=false;
  812. emit_reg(A_PUSH,S_L,R_ESI);
  813. end;
  814. }
  815. if lexlevel=(tprocdef(procdefinition).parast.symtablelevel) then
  816. begin
  817. new(r);
  818. reset_reference(r^);
  819. r^.offset:=procinfo^.framepointer_offset;
  820. r^.base:=procinfo^.framepointer;
  821. emit_ref(A_PUSH,S_L,r)
  822. end
  823. { this is only true if the difference is one !!
  824. but it cannot be more !! }
  825. else if (lexlevel=(tprocdef(procdefinition).parast.symtablelevel)-1) then
  826. begin
  827. emit_reg(A_PUSH,S_L,procinfo^.framepointer)
  828. end
  829. else if (lexlevel>(tprocdef(procdefinition).parast.symtablelevel)) then
  830. begin
  831. hregister:=getregister32;
  832. new(r);
  833. reset_reference(r^);
  834. r^.offset:=procinfo^.framepointer_offset;
  835. r^.base:=procinfo^.framepointer;
  836. emit_ref_reg(A_MOV,S_L,r,hregister);
  837. for i:=(tprocdef(procdefinition).parast.symtablelevel) to lexlevel-1 do
  838. begin
  839. new(r);
  840. reset_reference(r^);
  841. {we should get the correct frame_pointer_offset at each level
  842. how can we do this !!! }
  843. r^.offset:=procinfo^.framepointer_offset;
  844. r^.base:=hregister;
  845. emit_ref_reg(A_MOV,S_L,r,hregister);
  846. end;
  847. emit_reg(A_PUSH,S_L,hregister);
  848. ungetregister32(hregister);
  849. end
  850. else
  851. internalerror(25000);
  852. end;
  853. saveregvars(regs_to_push);
  854. if (po_virtualmethod in procdefinition.procoptions) and
  855. not(no_virtual_call) then
  856. begin
  857. { static functions contain the vmt_address in ESI }
  858. { also class methods }
  859. { Here it is quite tricky because it also depends }
  860. { on the methodpointer PM }
  861. getexplicitregister32(R_ESI);
  862. if assigned(aktprocdef) then
  863. begin
  864. if (((sp_static in aktprocdef.procsym.symoptions) or
  865. (po_classmethod in aktprocdef.procoptions)) and
  866. ((methodpointer=nil) or (methodpointer.nodetype=typen)))
  867. or
  868. (po_staticmethod in procdefinition.procoptions) or
  869. ((procdefinition.proctypeoption=potype_constructor) and
  870. { esi contains the vmt if we call a constructor via a class ref }
  871. assigned(methodpointer) and
  872. (methodpointer.resulttype.def.deftype=classrefdef)
  873. ) or
  874. { is_interface(tprocdef(procdefinition)._class) or }
  875. { ESI is loaded earlier }
  876. (po_classmethod in procdefinition.procoptions) then
  877. begin
  878. new(r);
  879. reset_reference(r^);
  880. r^.base:=R_ESI;
  881. end
  882. else
  883. begin
  884. new(r);
  885. reset_reference(r^);
  886. r^.base:=R_ESI;
  887. { this is one point where we need vmt_offset (PM) }
  888. r^.offset:= tprocdef(procdefinition)._class.vmt_offset;
  889. getexplicitregister32(R_EDI);
  890. emit_ref_reg(A_MOV,S_L,r,R_EDI);
  891. new(r);
  892. reset_reference(r^);
  893. r^.base:=R_EDI;
  894. end;
  895. end
  896. else
  897. { aktprocdef should be assigned, also in main program }
  898. internalerror(12345);
  899. {
  900. begin
  901. new(r);
  902. reset_reference(r^);
  903. r^.base:=R_ESI;
  904. emit_ref_reg(A_MOV,S_L,r,R_EDI);
  905. new(r);
  906. reset_reference(r^);
  907. r^.base:=R_EDI;
  908. end;
  909. }
  910. if tprocdef(procdefinition).extnumber=-1 then
  911. internalerror(44584);
  912. r^.offset:=tprocdef(procdefinition)._class.vmtmethodoffset(tprocdef(procdefinition).extnumber);
  913. if not(is_interface(tprocdef(procdefinition)._class)) and
  914. not(is_cppclass(tprocdef(procdefinition)._class)) then
  915. begin
  916. if (cs_check_object_ext in aktlocalswitches) then
  917. begin
  918. emit_sym(A_PUSH,S_L,
  919. newasmsymbol(tprocdef(procdefinition)._class.vmt_mangledname));
  920. emit_reg(A_PUSH,S_L,r^.base);
  921. emitcall('FPC_CHECK_OBJECT_EXT');
  922. end
  923. else if (cs_check_range in aktlocalswitches) then
  924. begin
  925. emit_reg(A_PUSH,S_L,r^.base);
  926. emitcall('FPC_CHECK_OBJECT');
  927. end;
  928. end;
  929. emit_ref(A_CALL,S_NO,r);
  930. ungetregister32(R_EDI);
  931. end
  932. else if not inlined then
  933. begin
  934. { We can call interrupts from within the smae code
  935. by just pushing the flags and CS PM }
  936. if (po_interrupt in procdefinition.procoptions) then
  937. begin
  938. emit_none(A_PUSHF,S_L);
  939. emit_reg(A_PUSH,S_L,R_CS);
  940. end;
  941. emitcall(tprocdef(procdefinition).mangledname);
  942. end
  943. else { inlined proc }
  944. { inlined code is in inlinecode }
  945. begin
  946. { process the inlinecode }
  947. secondpass(inlinecode);
  948. { free the args }
  949. if tprocdef(procdefinition).parast.datasize>0 then
  950. ungetpersistanttemp(tprocdef(procdefinition).parast.address_fixup);
  951. end;
  952. end
  953. else
  954. { now procedure variable case }
  955. begin
  956. secondpass(right);
  957. if (po_interrupt in procdefinition.procoptions) then
  958. begin
  959. emit_none(A_PUSHF,S_L);
  960. emit_reg(A_PUSH,S_L,R_CS);
  961. end;
  962. { procedure of object? }
  963. if (po_methodpointer in procdefinition.procoptions) then
  964. begin
  965. { method pointer can't be in a register }
  966. hregister:=R_NO;
  967. { do some hacking if we call a method pointer }
  968. { which is a class member }
  969. { else ESI is overwritten ! }
  970. if (right.location.reference.base=R_ESI) or
  971. (right.location.reference.index=R_ESI) then
  972. begin
  973. del_reference(right.location.reference);
  974. getexplicitregister32(R_EDI);
  975. emit_ref_reg(A_MOV,S_L,
  976. newreference(right.location.reference),R_EDI);
  977. hregister:=R_EDI;
  978. end;
  979. { load self, but not if it's already explicitly pushed }
  980. if not(po_containsself in procdefinition.procoptions) then
  981. begin
  982. { load ESI }
  983. inc(right.location.reference.offset,4);
  984. getexplicitregister32(R_ESI);
  985. emit_ref_reg(A_MOV,S_L,
  986. newreference(right.location.reference),R_ESI);
  987. dec(right.location.reference.offset,4);
  988. { push self pointer }
  989. emit_reg(A_PUSH,S_L,R_ESI);
  990. end;
  991. saveregvars($ff);
  992. if hregister=R_NO then
  993. emit_ref(A_CALL,S_NO,newreference(right.location.reference))
  994. else
  995. begin
  996. emit_reg(A_CALL,S_NO,hregister);
  997. ungetregister32(hregister);
  998. end;
  999. del_reference(right.location.reference);
  1000. end
  1001. else
  1002. begin
  1003. saveregvars($ff);
  1004. case right.location.loc of
  1005. LOC_REGISTER,LOC_CREGISTER:
  1006. begin
  1007. emit_reg(A_CALL,S_NO,right.location.register);
  1008. ungetregister32(right.location.register);
  1009. end
  1010. else
  1011. begin
  1012. emit_ref(A_CALL,S_NO,newreference(right.location.reference));
  1013. del_reference(right.location.reference);
  1014. end;
  1015. end;
  1016. end;
  1017. end;
  1018. { this was only for normal functions
  1019. displaced here so we also get
  1020. it to work for procvars PM }
  1021. if (not inlined) and (po_clearstack in procdefinition.procoptions) then
  1022. begin
  1023. { we also add the pop_size which is included in pushedparasize }
  1024. pop_size:=0;
  1025. { better than an add on all processors }
  1026. if pushedparasize=4 then
  1027. begin
  1028. getexplicitregister32(R_EDI);
  1029. emit_reg(A_POP,S_L,R_EDI);
  1030. ungetregister32(R_EDI);
  1031. end
  1032. { the pentium has two pipes and pop reg is pairable }
  1033. { but the registers must be different! }
  1034. else if (pushedparasize=8) and
  1035. not(cs_littlesize in aktglobalswitches) and
  1036. (aktoptprocessor=ClassP5) and
  1037. (procinfo^._class=nil) then
  1038. begin
  1039. getexplicitregister32(R_EDI);
  1040. emit_reg(A_POP,S_L,R_EDI);
  1041. ungetregister32(R_EDI);
  1042. exprasmList.concat(Tairegalloc.Alloc(R_ESI));
  1043. emit_reg(A_POP,S_L,R_ESI);
  1044. exprasmList.concat(Tairegalloc.DeAlloc(R_ESI));
  1045. end
  1046. else if pushedparasize<>0 then
  1047. emit_const_reg(A_ADD,S_L,pushedparasize,R_ESP);
  1048. end;
  1049. {$ifdef OPTALIGN}
  1050. if pop_esp then
  1051. emit_reg(A_POP,S_L,R_ESP);
  1052. {$endif OPTALIGN}
  1053. dont_call:
  1054. pushedparasize:=oldpushedparasize;
  1055. unused:=unusedregisters;
  1056. usablereg32:=usablecount;
  1057. {$ifdef TEMPREGDEBUG}
  1058. testregisters32;
  1059. {$endif TEMPREGDEBUG}
  1060. { a constructor could be a function with boolean result }
  1061. { if calling constructor called fail we
  1062. must jump directly to quickexitlabel PM
  1063. but only if it is a call of an inherited constructor }
  1064. if (inlined or
  1065. (right=nil)) and
  1066. (procdefinition.proctypeoption=potype_constructor) and
  1067. assigned(methodpointer) and
  1068. (methodpointer.nodetype=typen) and
  1069. (aktprocdef.proctypeoption=potype_constructor) then
  1070. begin
  1071. emitjmp(C_Z,faillabel);
  1072. end;
  1073. { call to AfterConstruction? }
  1074. if is_class(resulttype.def) and
  1075. (inlined or
  1076. (right=nil)) and
  1077. (procdefinition.proctypeoption=potype_constructor) and
  1078. assigned(methodpointer) and
  1079. (methodpointer.nodetype<>typen) then
  1080. begin
  1081. getlabel(constructorfailed);
  1082. emitjmp(C_Z,constructorfailed);
  1083. emit_reg(A_PUSH,S_L,R_ESI);
  1084. new(r);
  1085. reset_reference(r^);
  1086. r^.base:=R_ESI;
  1087. getexplicitregister32(R_EDI);
  1088. emit_ref_reg(A_MOV,S_L,r,R_EDI);
  1089. new(r);
  1090. reset_reference(r^);
  1091. r^.offset:=68;
  1092. r^.base:=R_EDI;
  1093. emit_ref(A_CALL,S_NO,r);
  1094. ungetregister32(R_EDI);
  1095. exprasmList.concat(Tairegalloc.Alloc(R_EAX));
  1096. emitlab(constructorfailed);
  1097. emit_reg_reg(A_MOV,S_L,R_ESI,R_EAX);
  1098. end;
  1099. { handle function results }
  1100. { structured results are easy to handle.... }
  1101. { needed also when result_no_used !! }
  1102. if (not is_void(resulttype.def)) and ret_in_param(resulttype.def) then
  1103. begin
  1104. location.loc:=LOC_MEM;
  1105. location.reference.symbol:=nil;
  1106. location.reference:=funcretref;
  1107. end;
  1108. { we have only to handle the result if it is used, but }
  1109. { ansi/widestrings must be registered, so we can dispose them }
  1110. if (not is_void(resulttype.def)) and ((nf_return_value_used in flags) or
  1111. is_ansistring(resulttype.def) or is_widestring(resulttype.def)) then
  1112. begin
  1113. { a contructor could be a function with boolean result }
  1114. if (inlined or
  1115. (right=nil)) and
  1116. (procdefinition.proctypeoption=potype_constructor) and
  1117. { quick'n'dirty check if it is a class or an object }
  1118. (resulttype.def.deftype=orddef) then
  1119. begin
  1120. { this fails if popsize > 0 PM }
  1121. location.loc:=LOC_FLAGS;
  1122. location.resflags:=F_NE;
  1123. if extended_new then
  1124. begin
  1125. {$ifdef test_dest_loc}
  1126. if dest_loc_known and (dest_loc_tree=p) then
  1127. mov_reg_to_dest(p,S_L,R_EAX)
  1128. else
  1129. {$endif test_dest_loc}
  1130. begin
  1131. hregister:=getexplicitregister32(R_EAX);
  1132. emit_reg_reg(A_MOV,S_L,R_EAX,hregister);
  1133. location.register:=hregister;
  1134. end;
  1135. end;
  1136. end
  1137. { structed results are easy to handle.... }
  1138. else if ret_in_param(resulttype.def) then
  1139. begin
  1140. {location.loc:=LOC_MEM;
  1141. stringdispose(location.reference.symbol);
  1142. location.reference:=funcretref;
  1143. already done above (PM) }
  1144. end
  1145. else
  1146. begin
  1147. if (resulttype.def.deftype in [orddef,enumdef]) then
  1148. begin
  1149. location.loc:=LOC_REGISTER;
  1150. case resulttype.def.size of
  1151. 4 :
  1152. begin
  1153. {$ifdef test_dest_loc}
  1154. if dest_loc_known and (dest_loc_tree=p) then
  1155. mov_reg_to_dest(p,S_L,R_EAX)
  1156. else
  1157. {$endif test_dest_loc}
  1158. begin
  1159. hregister:=getexplicitregister32(R_EAX);
  1160. emit_reg_reg(A_MOV,S_L,R_EAX,hregister);
  1161. location.register:=hregister;
  1162. end;
  1163. end;
  1164. 1 :
  1165. begin
  1166. {$ifdef test_dest_loc}
  1167. if dest_loc_known and (dest_loc_tree=p) then
  1168. mov_reg_to_dest(p,S_B,R_AL)
  1169. else
  1170. {$endif test_dest_loc}
  1171. begin
  1172. hregister:=getexplicitregister32(R_EAX);
  1173. emit_reg_reg(A_MOV,S_B,R_AL,reg32toreg8(hregister));
  1174. location.register:=reg32toreg8(hregister);
  1175. end;
  1176. end;
  1177. 2 :
  1178. begin
  1179. {$ifdef test_dest_loc}
  1180. if dest_loc_known and (dest_loc_tree=p) then
  1181. mov_reg_to_dest(p,S_W,R_AX)
  1182. else
  1183. {$endif test_dest_loc}
  1184. begin
  1185. hregister:=getexplicitregister32(R_EAX);
  1186. emit_reg_reg(A_MOV,S_W,R_AX,reg32toreg16(hregister));
  1187. location.register:=reg32toreg16(hregister);
  1188. end;
  1189. end;
  1190. 8 :
  1191. begin
  1192. {$ifdef test_dest_loc}
  1193. {$error Don't know what to do here}
  1194. {$endif test_dest_loc}
  1195. if R_EDX in unused then
  1196. begin
  1197. hregister2:=getexplicitregister32(R_EDX);
  1198. hregister:=getexplicitregister32(R_EAX);
  1199. end
  1200. else
  1201. begin
  1202. hregister:=getexplicitregister32(R_EAX);
  1203. hregister2:=getexplicitregister32(R_EDX);
  1204. end;
  1205. emit_reg_reg(A_MOV,S_L,R_EAX,hregister);
  1206. emit_reg_reg(A_MOV,S_L,R_EDX,hregister2);
  1207. location.registerlow:=hregister;
  1208. location.registerhigh:=hregister2;
  1209. end;
  1210. else internalerror(7);
  1211. end
  1212. end
  1213. else if (resulttype.def.deftype=floatdef) then
  1214. begin
  1215. location.loc:=LOC_FPU;
  1216. inc(fpuvaroffset);
  1217. end
  1218. else if is_ansistring(resulttype.def) or
  1219. is_widestring(resulttype.def) then
  1220. begin
  1221. hregister:=getexplicitregister32(R_EAX);
  1222. emit_reg_reg(A_MOV,S_L,R_EAX,hregister);
  1223. if tstringdef(resulttype.def).string_typ=st_widestring then
  1224. begin
  1225. gettempwidestringreference(hr);
  1226. decrstringref(resulttype.def,hr);
  1227. end
  1228. else
  1229. begin
  1230. gettempansistringreference(hr);
  1231. decrstringref(resulttype.def,hr);
  1232. end;
  1233. emit_reg_ref(A_MOV,S_L,hregister,
  1234. newreference(hr));
  1235. ungetregister32(hregister);
  1236. location.loc:=LOC_MEM;
  1237. location.reference:=hr;
  1238. end
  1239. else
  1240. begin
  1241. location.loc:=LOC_REGISTER;
  1242. {$ifdef test_dest_loc}
  1243. if dest_loc_known and (dest_loc_tree=p) then
  1244. mov_reg_to_dest(p,S_L,R_EAX)
  1245. else
  1246. {$endif test_dest_loc}
  1247. begin
  1248. hregister:=getexplicitregister32(R_EAX);
  1249. emit_reg_reg(A_MOV,S_L,R_EAX,hregister);
  1250. location.register:=hregister;
  1251. end;
  1252. end;
  1253. end;
  1254. end;
  1255. { perhaps i/o check ? }
  1256. if iolabel<>nil then
  1257. begin
  1258. emit_sym(A_PUSH,S_L,iolabel);
  1259. emitcall('FPC_IOCHECK');
  1260. end;
  1261. if pop_size>0 then
  1262. emit_const_reg(A_ADD,S_L,pop_size,R_ESP);
  1263. { restore registers }
  1264. popusedregisters(pushed);
  1265. { at last, restore instance pointer (SELF) }
  1266. if loadesi then
  1267. maybe_loadself;
  1268. pp:=tbinarynode(params);
  1269. while assigned(pp) do
  1270. begin
  1271. if assigned(pp.left) then
  1272. begin
  1273. if (pp.left.location.loc in [LOC_REFERENCE,LOC_MEM]) then
  1274. ungetiftemp(pp.left.location.reference);
  1275. { process also all nodes of an array of const }
  1276. if pp.left.nodetype=arrayconstructorn then
  1277. begin
  1278. if assigned(tarrayconstructornode(pp.left).left) then
  1279. begin
  1280. hp:=pp.left;
  1281. while assigned(hp) do
  1282. begin
  1283. if (tarrayconstructornode(tunarynode(hp).left).location.loc in [LOC_REFERENCE,LOC_MEM]) then
  1284. ungetiftemp(tarrayconstructornode(hp).left.location.reference);
  1285. hp:=tbinarynode(hp).right;
  1286. end;
  1287. end;
  1288. end;
  1289. end;
  1290. pp:=tbinarynode(pp.right);
  1291. end;
  1292. if inlined then
  1293. begin
  1294. ungetpersistanttemp(inlinecode.retoffset);
  1295. tprocdef(procdefinition).parast.address_fixup:=store_parast_fixup;
  1296. right:=inlinecode;
  1297. end;
  1298. if assigned(params) then
  1299. params.free;
  1300. { from now on the result can be freed normally }
  1301. if inlined and ret_in_param(resulttype.def) then
  1302. persistanttemptonormal(funcretref.offset);
  1303. { if return value is not used }
  1304. if (not(nf_return_value_used in flags)) and (not is_void(resulttype.def)) then
  1305. begin
  1306. if location.loc in [LOC_MEM,LOC_REFERENCE] then
  1307. begin
  1308. { data which must be finalized ? }
  1309. if (resulttype.def.needs_inittable) then
  1310. finalize(resulttype.def,location.reference,false);
  1311. { release unused temp }
  1312. ungetiftemp(location.reference)
  1313. end
  1314. else if location.loc=LOC_FPU then
  1315. begin
  1316. { release FPU stack }
  1317. emit_reg(A_FSTP,S_NO,R_ST0);
  1318. {
  1319. dec(fpuvaroffset);
  1320. do NOT decrement as the increment before
  1321. is not called for unused results PM }
  1322. end;
  1323. end;
  1324. end;
  1325. {*****************************************************************************
  1326. TI386PROCINLINENODE
  1327. *****************************************************************************}
  1328. procedure ti386procinlinenode.pass_2;
  1329. var st : tsymtable;
  1330. oldprocdef : tprocdef;
  1331. ps, i : longint;
  1332. tmpreg: tregister;
  1333. oldprocinfo : pprocinfo;
  1334. oldinlining_procedure,
  1335. nostackframe,make_global : boolean;
  1336. inlineentrycode,inlineexitcode : TAAsmoutput;
  1337. oldexitlabel,oldexit2label,oldquickexitlabel:tasmlabel;
  1338. oldunused,oldusableregs : tregisterset;
  1339. oldc_usableregs : longint;
  1340. oldreg_pushes : regvar_longintarray;
  1341. oldregvar_loaded,
  1342. oldis_reg_var : regvar_booleanarray;
  1343. {$ifdef TEMPREGDEBUG}
  1344. oldreg_user : regvar_ptreearray;
  1345. oldreg_releaser : regvar_ptreearray;
  1346. {$endif TEMPREGDEBUG}
  1347. {$ifdef GDB}
  1348. startlabel,endlabel : tasmlabel;
  1349. pp : pchar;
  1350. mangled_length : longint;
  1351. {$endif GDB}
  1352. begin
  1353. { deallocate the registers used for the current procedure's regvars }
  1354. if assigned(aktprocdef.regvarinfo) then
  1355. begin
  1356. with pregvarinfo(aktprocdef.regvarinfo)^ do
  1357. for i := 1 to maxvarregs do
  1358. if assigned(regvars[i]) then
  1359. store_regvar(exprasmlist,regvars[i].reg);
  1360. oldunused := unused;
  1361. oldusableregs := usableregs;
  1362. oldc_usableregs := c_usableregs;
  1363. oldreg_pushes := reg_pushes;
  1364. oldis_reg_var := is_reg_var;
  1365. oldregvar_loaded := regvar_loaded;
  1366. {$ifdef TEMPREGDEBUG}
  1367. oldreg_user := reg_user;
  1368. oldreg_releaser := reg_releaser;
  1369. {$endif TEMPREGDEBUG}
  1370. { make sure the register allocator knows what the regvars in the }
  1371. { inlined code block are (JM) }
  1372. resetusableregisters;
  1373. clearregistercount;
  1374. cleartempgen;
  1375. if assigned(inlineprocdef.regvarinfo) then
  1376. with pregvarinfo(inlineprocdef.regvarinfo)^ do
  1377. for i := 1 to maxvarregs do
  1378. if assigned(regvars[i]) then
  1379. begin
  1380. case regsize(regvars[i].reg) of
  1381. S_B: tmpreg := reg8toreg32(regvars[i].reg);
  1382. S_W: tmpreg := reg16toreg32(regvars[i].reg);
  1383. S_L: tmpreg := regvars[i].reg;
  1384. end;
  1385. usableregs:=usableregs-[tmpreg];
  1386. is_reg_var[tmpreg]:=true;
  1387. dec(c_usableregs);
  1388. end;
  1389. end;
  1390. oldinlining_procedure:=inlining_procedure;
  1391. oldexitlabel:=aktexitlabel;
  1392. oldexit2label:=aktexit2label;
  1393. oldquickexitlabel:=quickexitlabel;
  1394. getlabel(aktexitlabel);
  1395. getlabel(aktexit2label);
  1396. { we're inlining a procedure }
  1397. inlining_procedure:=true;
  1398. { save old procinfo }
  1399. getmem(oldprocinfo,sizeof(tprocinfo));
  1400. move(procinfo^,oldprocinfo^,sizeof(tprocinfo));
  1401. { set new procinfo }
  1402. aktprocdef:=inlineprocdef;
  1403. procinfo^.return_offset:=retoffset;
  1404. procinfo^.para_offset:=para_offset;
  1405. procinfo^.no_fast_exit:=false;
  1406. { arg space has been filled by the parent secondcall }
  1407. st:=aktprocdef.localst;
  1408. { set it to the same lexical level }
  1409. st.symtablelevel:=oldprocdef.localst.symtablelevel;
  1410. if st.datasize>0 then
  1411. begin
  1412. st.address_fixup:=gettempofsizepersistant(st.datasize)+st.datasize;
  1413. {$ifdef extdebug}
  1414. Comment(V_debug,'local symtable is at offset '+tostr(st.address_fixup));
  1415. exprasmList.concat(Tai_asm_comment.Create(strpnew(
  1416. 'local symtable is at offset '+tostr(st.address_fixup))));
  1417. {$endif extdebug}
  1418. end;
  1419. exprasmList.concat(Tai_Marker.Create(InlineStart));
  1420. {$ifdef extdebug}
  1421. exprasmList.concat(Tai_asm_comment.Create(strpnew('Start of inlined proc')));
  1422. {$endif extdebug}
  1423. {$ifdef GDB}
  1424. if (cs_debuginfo in aktmoduleswitches) then
  1425. begin
  1426. getaddrlabel(startlabel);
  1427. getaddrlabel(endlabel);
  1428. emitlab(startlabel);
  1429. inlineprocdef.localst.symtabletype:=inlinelocalsymtable;
  1430. inlineprocdef.parast.symtabletype:=inlineparasymtable;
  1431. { Here we must include the para and local symtable info }
  1432. tprocsym(inlineprocdef.procsym).concatstabto(withdebuglist);
  1433. { set it back for safety }
  1434. inlineprocdef.localst.symtabletype:=localsymtable;
  1435. inlineprocdef.parast.symtabletype:=parasymtable;
  1436. mangled_length:=length(oldprocdef.mangledname);
  1437. getmem(pp,mangled_length+50);
  1438. strpcopy(pp,'192,0,0,'+startlabel.name);
  1439. if (target_info.use_function_relative_addresses) then
  1440. begin
  1441. strpcopy(strend(pp),'-');
  1442. strpcopy(strend(pp),oldprocdef.mangledname);
  1443. end;
  1444. withdebugList.concat(Tai_stabn.Create(strnew(pp)));
  1445. end;
  1446. {$endif GDB}
  1447. { takes care of local data initialization }
  1448. inlineentrycode:=TAAsmoutput.Create;
  1449. inlineexitcode:=TAAsmoutput.Create;
  1450. ps:=para_size;
  1451. make_global:=false; { to avoid warning }
  1452. genentrycode(inlineentrycode,make_global,0,ps,nostackframe,true);
  1453. if po_assembler in aktprocdef.procoptions then
  1454. inlineentrycode.insert(Tai_marker.Create(asmblockstart));
  1455. exprasmList.concatlist(inlineentrycode);
  1456. secondpass(inlinetree);
  1457. genexitcode(inlineexitcode,0,false,true);
  1458. if po_assembler in aktprocdef.procoptions then
  1459. inlineexitcode.concat(Tai_marker.Create(asmblockend));
  1460. exprasmList.concatlist(inlineexitcode);
  1461. inlineentrycode.free;
  1462. inlineexitcode.free;
  1463. {$ifdef extdebug}
  1464. exprasmList.concat(Tai_asm_comment.Create(strpnew('End of inlined proc')));
  1465. {$endif extdebug}
  1466. exprasmList.concat(Tai_Marker.Create(InlineEnd));
  1467. {we can free the local data now, reset also the fixup address }
  1468. if st.datasize>0 then
  1469. begin
  1470. ungetpersistanttemp(st.address_fixup-st.datasize);
  1471. st.address_fixup:=0;
  1472. end;
  1473. { restore procinfo }
  1474. move(oldprocinfo^,procinfo^,sizeof(tprocinfo));
  1475. freemem(oldprocinfo,sizeof(tprocinfo));
  1476. {$ifdef GDB}
  1477. if (cs_debuginfo in aktmoduleswitches) then
  1478. begin
  1479. emitlab(endlabel);
  1480. strpcopy(pp,'224,0,0,'+endlabel.name);
  1481. if (target_info.use_function_relative_addresses) then
  1482. begin
  1483. strpcopy(strend(pp),'-');
  1484. strpcopy(strend(pp),oldprocdef.mangledname);
  1485. end;
  1486. withdebugList.concat(Tai_stabn.Create(strnew(pp)));
  1487. freemem(pp,mangled_length+50);
  1488. end;
  1489. {$endif GDB}
  1490. { restore }
  1491. aktprocdef:=oldprocdef;
  1492. aktexitlabel:=oldexitlabel;
  1493. aktexit2label:=oldexit2label;
  1494. quickexitlabel:=oldquickexitlabel;
  1495. inlining_procedure:=oldinlining_procedure;
  1496. { reallocate the registers used for the current procedure's regvars, }
  1497. { since they may have been used and then deallocated in the inlined }
  1498. { procedure (JM) }
  1499. if assigned(aktprocdef.regvarinfo) then
  1500. begin
  1501. unused := oldunused;
  1502. usableregs := oldusableregs;
  1503. c_usableregs := oldc_usableregs;
  1504. reg_pushes := oldreg_pushes;
  1505. is_reg_var := oldis_reg_var;
  1506. regvar_loaded := oldregvar_loaded;
  1507. {$ifdef TEMPREGDEBUG}
  1508. reg_user := oldreg_user;
  1509. reg_releaser := oldreg_releaser;
  1510. {$endif TEMPREGDEBUG}
  1511. end;
  1512. end;
  1513. begin
  1514. ccallparanode:=ti386callparanode;
  1515. ccallnode:=ti386callnode;
  1516. cprocinlinenode:=ti386procinlinenode;
  1517. end.
  1518. {
  1519. $Log$
  1520. Revision 1.36 2001-11-02 22:58:09 peter
  1521. * procsym definition rewrite
  1522. Revision 1.35 2001/10/25 21:22:41 peter
  1523. * calling convention rewrite
  1524. Revision 1.34 2001/10/21 12:33:07 peter
  1525. * array access for properties added
  1526. Revision 1.33 2001/09/09 08:50:15 jonas
  1527. * when calling an inline procedure inside a nested procedure, the
  1528. framepointer was being pushed on the stack, but this pushed framepointer
  1529. was never used nor removed from the stack again after the inlining was
  1530. done. It's now simply not pushed anymore, because the inlined procedure
  1531. can get the previous framepointer from the procedure in which it is being
  1532. inlined (merged)
  1533. Revision 1.32 2001/09/01 23:02:30 jonas
  1534. * i386*: call and jmp read their first operand
  1535. * cgcal: deallocate hlper register only after call statement (fixes bug
  1536. with "procedure of object" and optimizer reported to bugrep on
  1537. 2001/08/30) ('merged')
  1538. Revision 1.31 2001/08/29 12:18:08 jonas
  1539. + new createinternres() constructor for tcallnode to support setting a
  1540. custom resulttype
  1541. * compilerproc typeconversions now set the resulttype from the type
  1542. conversion for the generated call node, because the resulttype of
  1543. of the compilerproc helper isn't always exact (e.g. the ones that
  1544. return shortstrings, actually return a shortstring[x], where x is
  1545. specified by the typeconversion node)
  1546. * ti386callnode.pass_2 now always uses resulttype instead of
  1547. procsym.definition.rettype (so the custom resulttype, if any, is
  1548. always used). Note that this "rettype" stuff is only for use with
  1549. compilerprocs.
  1550. Revision 1.30 2001/08/26 13:36:56 florian
  1551. * some cg reorganisation
  1552. * some PPC updates
  1553. Revision 1.29 2001/08/19 21:11:21 florian
  1554. * some bugs fix:
  1555. - overload; with external procedures fixed
  1556. - better selection of routine to do an overloaded
  1557. type case
  1558. - ... some more
  1559. Revision 1.28 2001/08/06 21:40:50 peter
  1560. * funcret moved from tprocinfo to tprocdef
  1561. Revision 1.27 2001/07/08 21:00:16 peter
  1562. * various widestring updates, it works now mostly without charset
  1563. mapping supported
  1564. Revision 1.26 2001/07/01 20:16:20 peter
  1565. * alignmentinfo record added
  1566. * -Oa argument supports more alignment settings that can be specified
  1567. per type: PROC,LOOP,VARMIN,VARMAX,CONSTMIN,CONSTMAX,RECORDMIN
  1568. RECORDMAX,LOCALMIN,LOCALMAX. It is possible to set the mimimum
  1569. required alignment and the maximum usefull alignment. The final
  1570. alignment will be choosen per variable size dependent on these
  1571. settings
  1572. Revision 1.25 2001/06/04 11:48:02 peter
  1573. * better const to var checking
  1574. Revision 1.24 2001/05/19 21:22:53 peter
  1575. * function returning int64 inlining fixed
  1576. Revision 1.23 2001/05/16 15:11:42 jonas
  1577. * added missign begin..end pair (noticed by Carl)
  1578. Revision 1.22 2001/04/18 22:02:01 peter
  1579. * registration of targets and assemblers
  1580. Revision 1.21 2001/04/13 01:22:18 peter
  1581. * symtable change to classes
  1582. * range check generation and errors fixed, make cycle DEBUG=1 works
  1583. * memory leaks fixed
  1584. Revision 1.20 2001/04/02 21:20:36 peter
  1585. * resulttype rewrite
  1586. Revision 1.19 2001/03/11 22:58:51 peter
  1587. * getsym redesign, removed the globals srsym,srsymtable
  1588. Revision 1.18 2001/01/27 21:29:35 florian
  1589. * behavior -Oa optimized
  1590. Revision 1.17 2001/01/08 21:46:46 peter
  1591. * don't push high value for open array with cdecl;external;
  1592. Revision 1.16 2000/12/25 00:07:32 peter
  1593. + new tlinkedlist class (merge of old tstringqueue,tcontainer and
  1594. tlinkedlist objects)
  1595. Revision 1.15 2000/12/09 10:45:40 florian
  1596. * AfterConstructor isn't called anymore when a constructor failed
  1597. Revision 1.14 2000/12/07 17:19:46 jonas
  1598. * new constant handling: from now on, hex constants >$7fffffff are
  1599. parsed as unsigned constants (otherwise, $80000000 got sign extended
  1600. and became $ffffffff80000000), all constants in the longint range
  1601. become longints, all constants >$7fffffff and <=cardinal($ffffffff)
  1602. are cardinals and the rest are int64's.
  1603. * added lots of longint typecast to prevent range check errors in the
  1604. compiler and rtl
  1605. * type casts of symbolic ordinal constants are now preserved
  1606. * fixed bug where the original resulttype.def wasn't restored correctly
  1607. after doing a 64bit rangecheck
  1608. Revision 1.13 2000/12/05 11:44:33 jonas
  1609. + new integer regvar handling, should be much more efficient
  1610. Revision 1.12 2000/12/03 22:26:54 florian
  1611. * fixed web buzg 1275: problem with int64 functions results
  1612. Revision 1.11 2000/11/29 00:30:46 florian
  1613. * unused units removed from uses clause
  1614. * some changes for widestrings
  1615. Revision 1.10 2000/11/23 13:26:34 jonas
  1616. * fix for webbug 1066/1126
  1617. Revision 1.9 2000/11/22 15:12:06 jonas
  1618. * fixed inline-related problems (partially "merges")
  1619. Revision 1.8 2000/11/17 09:54:58 florian
  1620. * INT_CHECK_OBJECT_* isn't applied to interfaces anymore
  1621. Revision 1.7 2000/11/12 23:24:14 florian
  1622. * interfaces are basically running
  1623. Revision 1.6 2000/11/07 23:40:49 florian
  1624. + AfterConstruction and BeforeDestruction impemented
  1625. Revision 1.5 2000/11/06 23:15:01 peter
  1626. * added copyvaluepara call again
  1627. Revision 1.4 2000/11/04 14:25:23 florian
  1628. + merged Attila's changes for interfaces, not tested yet
  1629. Revision 1.3 2000/11/04 13:12:14 jonas
  1630. * check for nil pointers before calling getcopy
  1631. Revision 1.2 2000/10/31 22:02:56 peter
  1632. * symtable splitted, no real code changes
  1633. Revision 1.1 2000/10/15 09:33:31 peter
  1634. * moved n386*.pas to i386/ cpu_target dir
  1635. Revision 1.2 2000/10/14 10:14:48 peter
  1636. * moehrendorf oct 2000 rewrite
  1637. Revision 1.1 2000/10/10 17:31:56 florian
  1638. * initial revision
  1639. }