n386cal.pas 76 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771
  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. tainst,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. funcretref,refcountedtemp : 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 we allocate the temp. location for ansi- or widestrings }
  286. { already here, we avoid later a push/pop }
  287. if is_widestring(resulttype.def) then
  288. begin
  289. gettempwidestringreference(refcountedtemp);
  290. decrstringref(resulttype.def,refcountedtemp);
  291. end
  292. else if is_ansistring(resulttype.def) then
  293. begin
  294. gettempansistringreference(refcountedtemp);
  295. decrstringref(resulttype.def,refcountedtemp);
  296. end;
  297. if (procdefinition.proccalloption in [pocall_cdecl,pocall_cppdecl,pocall_stdcall]) then
  298. para_alignment:=4
  299. else
  300. para_alignment:=aktalignment.paraalign;
  301. if not assigned(procdefinition) then
  302. exit;
  303. { Deciding whether we may still need the parameters happens next (JM) }
  304. if assigned(left) then
  305. params:=left.getcopy
  306. else params := nil;
  307. if (procdefinition.proccalloption=pocall_inline) then
  308. begin
  309. inlined:=true;
  310. inlinecode:=tprocinlinenode(right);
  311. right:=nil;
  312. { set it to the same lexical level as the local symtable, becuase
  313. the para's are stored there }
  314. tprocdef(procdefinition).parast.symtablelevel:=aktprocdef.localst.symtablelevel;
  315. if assigned(params) then
  316. inlinecode.para_offset:=gettempofsizepersistant(inlinecode.para_size);
  317. store_parast_fixup:=tprocdef(procdefinition).parast.address_fixup;
  318. tprocdef(procdefinition).parast.address_fixup:=inlinecode.para_offset;
  319. {$ifdef extdebug}
  320. Comment(V_debug,
  321. 'inlined parasymtable is at offset '
  322. +tostr(tprocdef(procdefinition).parast.address_fixup));
  323. exprasmList.concat(Tai_asm_comment.Create(
  324. strpnew('inlined parasymtable is at offset '
  325. +tostr(tprocdef(procdefinition).parast.address_fixup))));
  326. {$endif extdebug}
  327. end;
  328. { only if no proc var }
  329. if inlined or
  330. not(assigned(right)) then
  331. is_con_or_destructor:=(procdefinition.proctypeoption in [potype_constructor,potype_destructor]);
  332. { proc variables destroy all registers }
  333. if (inlined or
  334. (right=nil)) and
  335. { virtual methods too }
  336. not(po_virtualmethod in procdefinition.procoptions) then
  337. begin
  338. if (cs_check_io in aktlocalswitches) and
  339. (po_iocheck in procdefinition.procoptions) and
  340. not(po_iocheck in aktprocdef.procoptions) then
  341. begin
  342. getaddrlabel(iolabel);
  343. emitlab(iolabel);
  344. end
  345. else
  346. iolabel:=nil;
  347. { save all used registers }
  348. regs_to_push := tprocdef(procdefinition).usedregisters;
  349. pushusedregisters(pushed,regs_to_push);
  350. { give used registers through }
  351. usedinproc:=usedinproc or tprocdef(procdefinition).usedregisters;
  352. end
  353. else
  354. begin
  355. regs_to_push := $ff;
  356. pushusedregisters(pushed,regs_to_push);
  357. usedinproc:=$ff;
  358. { no IO check for methods and procedure variables }
  359. iolabel:=nil;
  360. end;
  361. { generate the code for the parameter and push them }
  362. oldpushedparasize:=pushedparasize;
  363. pushedparasize:=0;
  364. pop_size:=0;
  365. { no inc esp for inlined procedure
  366. and for objects constructors PM }
  367. if inlined or
  368. ((procdefinition.proctypeoption=potype_constructor) and
  369. { quick'n'dirty check if it is a class or an object }
  370. (resulttype.def.deftype=orddef)) then
  371. pop_allowed:=false
  372. else
  373. pop_allowed:=true;
  374. if pop_allowed then
  375. begin
  376. { Old pushedsize aligned on 4 ? }
  377. i:=oldpushedparasize and 3;
  378. if i>0 then
  379. inc(pop_size,4-i);
  380. { This parasize aligned on 4 ? }
  381. i:=procdefinition.para_size(para_alignment) and 3;
  382. if i>0 then
  383. inc(pop_size,4-i);
  384. { insert the opcode and update pushedparasize }
  385. { never push 4 or more !! }
  386. pop_size:=pop_size mod 4;
  387. if pop_size>0 then
  388. begin
  389. inc(pushedparasize,pop_size);
  390. emit_const_reg(A_SUB,S_L,pop_size,R_ESP);
  391. {$ifdef GDB}
  392. if (cs_debuginfo in aktmoduleswitches) and
  393. (exprasmList.first=exprasmList.last) then
  394. exprasmList.concat(Tai_force_line.Create);
  395. {$endif GDB}
  396. end;
  397. end;
  398. {$ifdef OPTALIGN}
  399. if pop_allowed and (cs_align in aktglobalswitches) then
  400. begin
  401. pop_esp:=true;
  402. push_size:=procdefinition.para_size(para_alignment);
  403. { !!!! here we have to take care of return type, self
  404. and nested procedures
  405. }
  406. inc(push_size,12);
  407. emit_reg_reg(A_MOV,S_L,R_ESP,R_EDI);
  408. if (push_size mod 8)=0 then
  409. emit_const_reg(A_AND,S_L,$fffffff8,R_ESP)
  410. else
  411. begin
  412. emit_const_reg(A_SUB,S_L,push_size,R_ESP);
  413. emit_const_reg(A_AND,S_L,$fffffff8,R_ESP);
  414. emit_const_reg(A_SUB,S_L,push_size,R_ESP);
  415. end;
  416. emit_reg(A_PUSH,S_L,R_EDI);
  417. end
  418. else
  419. pop_esp:=false;
  420. {$endif OPTALIGN}
  421. if (not is_void(resulttype.def)) and
  422. ret_in_param(resulttype.def) then
  423. begin
  424. funcretref.symbol:=nil;
  425. {$ifdef test_dest_loc}
  426. if dest_loc_known and (dest_loc_tree=p) and
  427. (dest_loc.loc in [LOC_REFERENCE,LOC_MEM]) then
  428. begin
  429. funcretref:=dest_loc.reference;
  430. if assigned(dest_loc.reference.symbol) then
  431. funcretref.symbol:=stringdup(dest_loc.reference.symbol^);
  432. in_dest_loc:=true;
  433. end
  434. else
  435. {$endif test_dest_loc}
  436. if inlined then
  437. begin
  438. reset_reference(funcretref);
  439. funcretref.offset:=gettempofsizepersistant(resulttype.def.size);
  440. funcretref.base:=procinfo^.framepointer;
  441. {$ifdef extdebug}
  442. Comment(V_debug,'function return value is at offset '
  443. +tostr(funcretref.offset));
  444. exprasmlist.concat(tai_asm_comment.create(
  445. strpnew('function return value is at offset '
  446. +tostr(funcretref.offset))));
  447. {$endif extdebug}
  448. end
  449. else
  450. gettempofsizereference(resulttype.def.size,funcretref);
  451. end;
  452. if assigned(params) then
  453. begin
  454. { be found elsewhere }
  455. if inlined then
  456. para_offset:=tprocdef(procdefinition).parast.address_fixup+
  457. tprocdef(procdefinition).parast.datasize
  458. else
  459. para_offset:=0;
  460. if not(inlined) and
  461. assigned(right) then
  462. tcallparanode(params).secondcallparan(TParaItem(tabstractprocdef(right.resulttype.def).Para.first),
  463. (po_leftright in procdefinition.procoptions),inlined,
  464. (procdefinition.proccalloption in [pocall_cdecl,pocall_cppdecl]),
  465. para_alignment,para_offset)
  466. else
  467. tcallparanode(params).secondcallparan(TParaItem(procdefinition.Para.first),
  468. (po_leftright in procdefinition.procoptions),inlined,
  469. (procdefinition.proccalloption in [pocall_cdecl,pocall_cppdecl]),
  470. para_alignment,para_offset);
  471. end;
  472. if inlined then
  473. inlinecode.retoffset:=gettempofsizepersistant(Align(resulttype.def.size,aktalignment.paraalign));
  474. if ret_in_param(resulttype.def) then
  475. begin
  476. { This must not be counted for C code
  477. complex return address is removed from stack
  478. by function itself ! }
  479. {$ifdef OLD_C_STACK}
  480. inc(pushedparasize,4); { lets try without it PM }
  481. {$endif not OLD_C_STACK}
  482. if inlined then
  483. begin
  484. getexplicitregister32(R_EDI);
  485. emit_ref_reg(A_LEA,S_L,
  486. newreference(funcretref),R_EDI);
  487. r:=new_reference(procinfo^.framepointer,inlinecode.retoffset);
  488. emit_reg_ref(A_MOV,S_L,R_EDI,r);
  489. ungetregister32(R_EDI);
  490. end
  491. else
  492. emitpushreferenceaddr(funcretref);
  493. end;
  494. { procedure variable ? }
  495. if inlined or
  496. (right=nil) then
  497. begin
  498. { overloaded operator has no symtable }
  499. { push self }
  500. if assigned(symtableproc) and
  501. (symtableproc.symtabletype=withsymtable) then
  502. begin
  503. { dirty trick to avoid the secondcall below }
  504. methodpointer:=ccallparanode.create(nil,nil);
  505. methodpointer.location.loc:=LOC_REGISTER;
  506. getexplicitregister32(R_ESI);
  507. methodpointer.location.register:=R_ESI;
  508. { ARGHHH this is wrong !!!
  509. if we can init from base class for a child
  510. class that the wrong VMT will be
  511. transfered to constructor !! }
  512. methodpointer.resulttype:=
  513. twithnode(twithsymtable(symtableproc).withnode).left.resulttype;
  514. { make a reference }
  515. new(r);
  516. reset_reference(r^);
  517. { if assigned(ptree(twithsymtable(symtable).withnode)^.pref) then
  518. begin
  519. r^:=ptree(twithsymtable(symtable).withnode)^.pref^;
  520. end
  521. else
  522. begin
  523. r^.offset:=symtable.datasize;
  524. r^.base:=procinfo^.framepointer;
  525. end; }
  526. r^:=twithnode(twithsymtable(symtableproc).withnode).withreference^;
  527. if ((not(nf_islocal in twithnode(twithsymtable(symtableproc).withnode).flags)) and
  528. (not twithsymtable(symtableproc).direct_with)) or
  529. is_class_or_interface(methodpointer.resulttype.def) then
  530. emit_ref_reg(A_MOV,S_L,r,R_ESI)
  531. else
  532. emit_ref_reg(A_LEA,S_L,r,R_ESI);
  533. end;
  534. { push self }
  535. if assigned(symtableproc) and
  536. ((symtableproc.symtabletype=objectsymtable) or
  537. (symtableproc.symtabletype=withsymtable)) then
  538. begin
  539. if assigned(methodpointer) then
  540. begin
  541. {
  542. if methodpointer^.resulttype.def=classrefdef then
  543. begin
  544. two possibilities:
  545. 1. constructor
  546. 2. class method
  547. end
  548. else }
  549. begin
  550. case methodpointer.nodetype of
  551. typen:
  552. begin
  553. { direct call to inherited method }
  554. if (po_abstractmethod in procdefinition.procoptions) then
  555. begin
  556. CGMessage(cg_e_cant_call_abstract_method);
  557. goto dont_call;
  558. end;
  559. { generate no virtual call }
  560. no_virtual_call:=true;
  561. if (sp_static in symtableprocentry.symoptions) then
  562. begin
  563. { well lets put the VMT address directly into ESI }
  564. { it is kind of dirty but that is the simplest }
  565. { way to accept virtual static functions (PM) }
  566. loadesi:=true;
  567. { if no VMT just use $0 bug0214 PM }
  568. getexplicitregister32(R_ESI);
  569. if not(oo_has_vmt in tobjectdef(methodpointer.resulttype.def).objectoptions) then
  570. emit_const_reg(A_MOV,S_L,0,R_ESI)
  571. else
  572. begin
  573. emit_sym_ofs_reg(A_MOV,S_L,
  574. newasmsymbol(tobjectdef(methodpointer.resulttype.def).vmt_mangledname),
  575. 0,R_ESI);
  576. end;
  577. { emit_reg(A_PUSH,S_L,R_ESI);
  578. this is done below !! }
  579. end
  580. else
  581. { this is a member call, so ESI isn't modfied }
  582. loadesi:=false;
  583. { a class destructor needs a flag }
  584. if is_class(tobjectdef(methodpointer.resulttype.def)) and
  585. (procdefinition.proctypeoption=potype_destructor) then
  586. begin
  587. push_int(0);
  588. emit_reg(A_PUSH,S_L,R_ESI);
  589. end;
  590. if not(is_con_or_destructor and
  591. is_class(methodpointer.resulttype.def) and
  592. (procdefinition.proctypeoption in [potype_constructor,potype_destructor])
  593. ) then
  594. emit_reg(A_PUSH,S_L,R_ESI);
  595. { if an inherited con- or destructor should be }
  596. { called in a con- or destructor then a warning }
  597. { will be made }
  598. { con- and destructors need a pointer to the vmt }
  599. if is_con_or_destructor and
  600. is_object(methodpointer.resulttype.def) and
  601. assigned(aktprocdef) then
  602. begin
  603. if not(aktprocdef.proctypeoption in
  604. [potype_constructor,potype_destructor]) then
  605. CGMessage(cg_w_member_cd_call_from_method);
  606. end;
  607. { class destructors get there flag above }
  608. { constructor flags ? }
  609. if is_con_or_destructor and
  610. not(
  611. is_class(methodpointer.resulttype.def) and
  612. assigned(aktprocdef) and
  613. (aktprocdef.proctypeoption=potype_destructor)) then
  614. begin
  615. { a constructor needs also a flag }
  616. if is_class(methodpointer.resulttype.def) then
  617. push_int(0);
  618. push_int(0);
  619. end;
  620. end;
  621. hnewn:
  622. begin
  623. { extended syntax of new }
  624. { ESI must be zero }
  625. getexplicitregister32(R_ESI);
  626. emit_reg_reg(A_XOR,S_L,R_ESI,R_ESI);
  627. emit_reg(A_PUSH,S_L,R_ESI);
  628. { insert the vmt }
  629. emit_sym(A_PUSH,S_L,
  630. newasmsymbol(tobjectdef(methodpointer.resulttype.def).vmt_mangledname));
  631. extended_new:=true;
  632. end;
  633. hdisposen:
  634. begin
  635. secondpass(methodpointer);
  636. { destructor with extended syntax called from dispose }
  637. { hdisposen always deliver LOC_REFERENCE }
  638. getexplicitregister32(R_ESI);
  639. emit_ref_reg(A_LEA,S_L,
  640. newreference(methodpointer.location.reference),R_ESI);
  641. del_reference(methodpointer.location.reference);
  642. emit_reg(A_PUSH,S_L,R_ESI);
  643. emit_sym(A_PUSH,S_L,
  644. newasmsymbol(tobjectdef(methodpointer.resulttype.def).vmt_mangledname));
  645. end;
  646. else
  647. begin
  648. { call to an instance member }
  649. if (symtableproc.symtabletype<>withsymtable) then
  650. begin
  651. secondpass(methodpointer);
  652. getexplicitregister32(R_ESI);
  653. case methodpointer.location.loc of
  654. LOC_CREGISTER,
  655. LOC_REGISTER:
  656. begin
  657. emit_reg_reg(A_MOV,S_L,methodpointer.location.register,R_ESI);
  658. ungetregister32(methodpointer.location.register);
  659. end;
  660. else
  661. begin
  662. if (methodpointer.resulttype.def.deftype=classrefdef) or
  663. is_class_or_interface(methodpointer.resulttype.def) then
  664. emit_ref_reg(A_MOV,S_L,
  665. newreference(methodpointer.location.reference),R_ESI)
  666. else
  667. emit_ref_reg(A_LEA,S_L,
  668. newreference(methodpointer.location.reference),R_ESI);
  669. del_reference(methodpointer.location.reference);
  670. end;
  671. end;
  672. end;
  673. { when calling a class method, we have to load ESI with the VMT !
  674. But, not for a class method via self }
  675. if not(po_containsself in procdefinition.procoptions) then
  676. begin
  677. if (po_classmethod in procdefinition.procoptions) and
  678. not(methodpointer.resulttype.def.deftype=classrefdef) then
  679. begin
  680. { class method needs current VMT }
  681. getexplicitregister32(R_ESI);
  682. new(r);
  683. reset_reference(r^);
  684. r^.base:=R_ESI;
  685. r^.offset:= tprocdef(procdefinition)._class.vmt_offset;
  686. emit_ref_reg(A_MOV,S_L,r,R_ESI);
  687. end;
  688. { direct call to destructor: remove data }
  689. if (procdefinition.proctypeoption=potype_destructor) and
  690. is_class(methodpointer.resulttype.def) then
  691. emit_const(A_PUSH,S_L,1);
  692. { direct call to class constructor, don't allocate memory }
  693. if (procdefinition.proctypeoption=potype_constructor) and
  694. is_class(methodpointer.resulttype.def) then
  695. begin
  696. emit_const(A_PUSH,S_L,0);
  697. emit_const(A_PUSH,S_L,0);
  698. end
  699. else
  700. begin
  701. { constructor call via classreference => allocate memory }
  702. if (procdefinition.proctypeoption=potype_constructor) and
  703. (methodpointer.resulttype.def.deftype=classrefdef) and
  704. is_class(tclassrefdef(methodpointer.resulttype.def).pointertype.def) then
  705. emit_const(A_PUSH,S_L,1);
  706. emit_reg(A_PUSH,S_L,R_ESI);
  707. end;
  708. end;
  709. if is_con_or_destructor then
  710. begin
  711. { classes don't get a VMT pointer pushed }
  712. if is_object(methodpointer.resulttype.def) then
  713. begin
  714. if (procdefinition.proctypeoption=potype_constructor) then
  715. begin
  716. { it's no bad idea, to insert the VMT }
  717. emit_sym(A_PUSH,S_L,newasmsymbol(
  718. tobjectdef(methodpointer.resulttype.def).vmt_mangledname));
  719. end
  720. { destructors haven't to dispose the instance, if this is }
  721. { a direct call }
  722. else
  723. push_int(0);
  724. end;
  725. end;
  726. end;
  727. end;
  728. end;
  729. end
  730. else
  731. begin
  732. if (po_classmethod in procdefinition.procoptions) and
  733. not(
  734. assigned(aktprocdef) and
  735. (po_classmethod in aktprocdef.procoptions)
  736. ) then
  737. begin
  738. { class method needs current VMT }
  739. getexplicitregister32(R_ESI);
  740. new(r);
  741. reset_reference(r^);
  742. r^.base:=R_ESI;
  743. r^.offset:= tprocdef(procdefinition)._class.vmt_offset;
  744. emit_ref_reg(A_MOV,S_L,r,R_ESI);
  745. end
  746. else
  747. begin
  748. { member call, ESI isn't modified }
  749. loadesi:=false;
  750. end;
  751. { direct call to destructor: don't remove data! }
  752. if is_class(procinfo^._class) then
  753. begin
  754. if (procdefinition.proctypeoption=potype_destructor) then
  755. begin
  756. emit_const(A_PUSH,S_L,0);
  757. emit_reg(A_PUSH,S_L,R_ESI);
  758. end
  759. else if (procdefinition.proctypeoption=potype_constructor) then
  760. begin
  761. emit_const(A_PUSH,S_L,0);
  762. emit_const(A_PUSH,S_L,0);
  763. end
  764. else
  765. emit_reg(A_PUSH,S_L,R_ESI);
  766. end
  767. else if is_object(procinfo^._class) then
  768. begin
  769. emit_reg(A_PUSH,S_L,R_ESI);
  770. if is_con_or_destructor then
  771. begin
  772. if (procdefinition.proctypeoption=potype_constructor) then
  773. begin
  774. { it's no bad idea, to insert the VMT }
  775. emit_sym(A_PUSH,S_L,newasmsymbol(
  776. procinfo^._class.vmt_mangledname));
  777. end
  778. { destructors haven't to dispose the instance, if this is }
  779. { a direct call }
  780. else
  781. push_int(0);
  782. end;
  783. end
  784. else
  785. Internalerror(200006165);
  786. end;
  787. end;
  788. { call to BeforeDestruction? }
  789. if (procdefinition.proctypeoption=potype_destructor) and
  790. assigned(methodpointer) and
  791. (methodpointer.nodetype<>typen) and
  792. is_class(tobjectdef(methodpointer.resulttype.def)) and
  793. (inlined or
  794. (right=nil)) then
  795. begin
  796. emit_reg(A_PUSH,S_L,R_ESI);
  797. new(r);
  798. reset_reference(r^);
  799. r^.base:=R_ESI;
  800. getexplicitregister32(R_EDI);
  801. emit_ref_reg(A_MOV,S_L,r,R_EDI);
  802. new(r);
  803. reset_reference(r^);
  804. r^.offset:=72;
  805. r^.base:=R_EDI;
  806. emit_ref(A_CALL,S_NO,r);
  807. ungetregister32(R_EDI);
  808. end;
  809. { push base pointer ?}
  810. { never when inlining, since if necessary, the base pointer }
  811. { can/will be gottten from the current procedure's symtable }
  812. { (JM) }
  813. if not inlined then
  814. if (lexlevel>=normal_function_level) and assigned(tprocdef(procdefinition).parast) and
  815. ((tprocdef(procdefinition).parast.symtablelevel)>normal_function_level) then
  816. begin
  817. { if we call a nested function in a method, we must }
  818. { push also SELF! }
  819. { THAT'S NOT TRUE, we have to load ESI via frame pointer }
  820. { access }
  821. {
  822. begin
  823. loadesi:=false;
  824. emit_reg(A_PUSH,S_L,R_ESI);
  825. end;
  826. }
  827. if lexlevel=(tprocdef(procdefinition).parast.symtablelevel) then
  828. begin
  829. new(r);
  830. reset_reference(r^);
  831. r^.offset:=procinfo^.framepointer_offset;
  832. r^.base:=procinfo^.framepointer;
  833. emit_ref(A_PUSH,S_L,r)
  834. end
  835. { this is only true if the difference is one !!
  836. but it cannot be more !! }
  837. else if (lexlevel=(tprocdef(procdefinition).parast.symtablelevel)-1) then
  838. begin
  839. emit_reg(A_PUSH,S_L,procinfo^.framepointer)
  840. end
  841. else if (lexlevel>(tprocdef(procdefinition).parast.symtablelevel)) then
  842. begin
  843. hregister:=getregisterint;
  844. new(r);
  845. reset_reference(r^);
  846. r^.offset:=procinfo^.framepointer_offset;
  847. r^.base:=procinfo^.framepointer;
  848. emit_ref_reg(A_MOV,S_L,r,hregister);
  849. for i:=(tprocdef(procdefinition).parast.symtablelevel) to lexlevel-1 do
  850. begin
  851. new(r);
  852. reset_reference(r^);
  853. {we should get the correct frame_pointer_offset at each level
  854. how can we do this !!! }
  855. r^.offset:=procinfo^.framepointer_offset;
  856. r^.base:=hregister;
  857. emit_ref_reg(A_MOV,S_L,r,hregister);
  858. end;
  859. emit_reg(A_PUSH,S_L,hregister);
  860. ungetregister32(hregister);
  861. end
  862. else
  863. internalerror(25000);
  864. end;
  865. saveregvars(regs_to_push);
  866. if (po_virtualmethod in procdefinition.procoptions) and
  867. not(no_virtual_call) then
  868. begin
  869. { static functions contain the vmt_address in ESI }
  870. { also class methods }
  871. { Here it is quite tricky because it also depends }
  872. { on the methodpointer PM }
  873. getexplicitregister32(R_ESI);
  874. if assigned(aktprocdef) then
  875. begin
  876. if (((sp_static in aktprocdef.procsym.symoptions) or
  877. (po_classmethod in aktprocdef.procoptions)) and
  878. ((methodpointer=nil) or (methodpointer.nodetype=typen)))
  879. or
  880. (po_staticmethod in procdefinition.procoptions) or
  881. ((procdefinition.proctypeoption=potype_constructor) and
  882. { esi contains the vmt if we call a constructor via a class ref }
  883. assigned(methodpointer) and
  884. (methodpointer.resulttype.def.deftype=classrefdef)
  885. ) or
  886. { is_interface(tprocdef(procdefinition)._class) or }
  887. { ESI is loaded earlier }
  888. (po_classmethod in procdefinition.procoptions) then
  889. begin
  890. new(r);
  891. reset_reference(r^);
  892. r^.base:=R_ESI;
  893. end
  894. else
  895. begin
  896. new(r);
  897. reset_reference(r^);
  898. r^.base:=R_ESI;
  899. { this is one point where we need vmt_offset (PM) }
  900. r^.offset:= tprocdef(procdefinition)._class.vmt_offset;
  901. getexplicitregister32(R_EDI);
  902. emit_ref_reg(A_MOV,S_L,r,R_EDI);
  903. new(r);
  904. reset_reference(r^);
  905. r^.base:=R_EDI;
  906. end;
  907. end
  908. else
  909. { aktprocdef should be assigned, also in main program }
  910. internalerror(12345);
  911. {
  912. begin
  913. new(r);
  914. reset_reference(r^);
  915. r^.base:=R_ESI;
  916. emit_ref_reg(A_MOV,S_L,r,R_EDI);
  917. new(r);
  918. reset_reference(r^);
  919. r^.base:=R_EDI;
  920. end;
  921. }
  922. if tprocdef(procdefinition).extnumber=-1 then
  923. internalerror(44584);
  924. r^.offset:=tprocdef(procdefinition)._class.vmtmethodoffset(tprocdef(procdefinition).extnumber);
  925. if not(is_interface(tprocdef(procdefinition)._class)) and
  926. not(is_cppclass(tprocdef(procdefinition)._class)) then
  927. begin
  928. if (cs_check_object_ext in aktlocalswitches) then
  929. begin
  930. emit_sym(A_PUSH,S_L,
  931. newasmsymbol(tprocdef(procdefinition)._class.vmt_mangledname));
  932. emit_reg(A_PUSH,S_L,r^.base);
  933. emitcall('FPC_CHECK_OBJECT_EXT');
  934. end
  935. else if (cs_check_range in aktlocalswitches) then
  936. begin
  937. emit_reg(A_PUSH,S_L,r^.base);
  938. emitcall('FPC_CHECK_OBJECT');
  939. end;
  940. end;
  941. emit_ref(A_CALL,S_NO,r);
  942. ungetregister32(R_EDI);
  943. end
  944. else if not inlined then
  945. begin
  946. { We can call interrupts from within the smae code
  947. by just pushing the flags and CS PM }
  948. if (po_interrupt in procdefinition.procoptions) then
  949. begin
  950. emit_none(A_PUSHF,S_L);
  951. emit_reg(A_PUSH,S_L,R_CS);
  952. end;
  953. emitcall(tprocdef(procdefinition).mangledname);
  954. end
  955. else { inlined proc }
  956. { inlined code is in inlinecode }
  957. begin
  958. { process the inlinecode }
  959. secondpass(inlinecode);
  960. { free the args }
  961. if tprocdef(procdefinition).parast.datasize>0 then
  962. ungetpersistanttemp(tprocdef(procdefinition).parast.address_fixup);
  963. end;
  964. end
  965. else
  966. { now procedure variable case }
  967. begin
  968. secondpass(right);
  969. if (po_interrupt in procdefinition.procoptions) then
  970. begin
  971. emit_none(A_PUSHF,S_L);
  972. emit_reg(A_PUSH,S_L,R_CS);
  973. end;
  974. { procedure of object? }
  975. if (po_methodpointer in procdefinition.procoptions) then
  976. begin
  977. { method pointer can't be in a register }
  978. hregister:=R_NO;
  979. { do some hacking if we call a method pointer }
  980. { which is a class member }
  981. { else ESI is overwritten ! }
  982. if (right.location.reference.base=R_ESI) or
  983. (right.location.reference.index=R_ESI) then
  984. begin
  985. del_reference(right.location.reference);
  986. getexplicitregister32(R_EDI);
  987. emit_ref_reg(A_MOV,S_L,
  988. newreference(right.location.reference),R_EDI);
  989. hregister:=R_EDI;
  990. end;
  991. { load self, but not if it's already explicitly pushed }
  992. if not(po_containsself in procdefinition.procoptions) then
  993. begin
  994. { load ESI }
  995. inc(right.location.reference.offset,4);
  996. getexplicitregister32(R_ESI);
  997. emit_ref_reg(A_MOV,S_L,
  998. newreference(right.location.reference),R_ESI);
  999. dec(right.location.reference.offset,4);
  1000. { push self pointer }
  1001. emit_reg(A_PUSH,S_L,R_ESI);
  1002. end;
  1003. saveregvars($ff);
  1004. if hregister=R_NO then
  1005. emit_ref(A_CALL,S_NO,newreference(right.location.reference))
  1006. else
  1007. begin
  1008. emit_reg(A_CALL,S_NO,hregister);
  1009. ungetregister32(hregister);
  1010. end;
  1011. del_reference(right.location.reference);
  1012. end
  1013. else
  1014. begin
  1015. saveregvars($ff);
  1016. case right.location.loc of
  1017. LOC_REGISTER,LOC_CREGISTER:
  1018. begin
  1019. emit_reg(A_CALL,S_NO,right.location.register);
  1020. ungetregister32(right.location.register);
  1021. end
  1022. else
  1023. begin
  1024. emit_ref(A_CALL,S_NO,newreference(right.location.reference));
  1025. del_reference(right.location.reference);
  1026. end;
  1027. end;
  1028. end;
  1029. end;
  1030. { this was only for normal functions
  1031. displaced here so we also get
  1032. it to work for procvars PM }
  1033. if (not inlined) and (po_clearstack in procdefinition.procoptions) then
  1034. begin
  1035. { we also add the pop_size which is included in pushedparasize }
  1036. pop_size:=0;
  1037. { better than an add on all processors }
  1038. if pushedparasize=4 then
  1039. begin
  1040. getexplicitregister32(R_EDI);
  1041. emit_reg(A_POP,S_L,R_EDI);
  1042. ungetregister32(R_EDI);
  1043. end
  1044. { the pentium has two pipes and pop reg is pairable }
  1045. { but the registers must be different! }
  1046. else if (pushedparasize=8) and
  1047. not(cs_littlesize in aktglobalswitches) and
  1048. (aktoptprocessor=ClassP5) and
  1049. (procinfo^._class=nil) then
  1050. begin
  1051. getexplicitregister32(R_EDI);
  1052. emit_reg(A_POP,S_L,R_EDI);
  1053. ungetregister32(R_EDI);
  1054. exprasmList.concat(Tairegalloc.Alloc(R_ESI));
  1055. emit_reg(A_POP,S_L,R_ESI);
  1056. exprasmList.concat(Tairegalloc.DeAlloc(R_ESI));
  1057. end
  1058. else if pushedparasize<>0 then
  1059. emit_const_reg(A_ADD,S_L,pushedparasize,R_ESP);
  1060. end;
  1061. {$ifdef OPTALIGN}
  1062. if pop_esp then
  1063. emit_reg(A_POP,S_L,R_ESP);
  1064. {$endif OPTALIGN}
  1065. dont_call:
  1066. pushedparasize:=oldpushedparasize;
  1067. unused:=unusedregisters;
  1068. usablereg32:=usablecount;
  1069. {$ifdef TEMPREGDEBUG}
  1070. testregisters32;
  1071. {$endif TEMPREGDEBUG}
  1072. { a constructor could be a function with boolean result }
  1073. { if calling constructor called fail we
  1074. must jump directly to quickexitlabel PM
  1075. but only if it is a call of an inherited constructor }
  1076. if (inlined or
  1077. (right=nil)) and
  1078. (procdefinition.proctypeoption=potype_constructor) and
  1079. assigned(methodpointer) and
  1080. (methodpointer.nodetype=typen) and
  1081. (aktprocdef.proctypeoption=potype_constructor) then
  1082. begin
  1083. emitjmp(C_Z,faillabel);
  1084. end;
  1085. { call to AfterConstruction? }
  1086. if is_class(resulttype.def) and
  1087. (inlined or
  1088. (right=nil)) and
  1089. (procdefinition.proctypeoption=potype_constructor) and
  1090. assigned(methodpointer) and
  1091. (methodpointer.nodetype<>typen) then
  1092. begin
  1093. getlabel(constructorfailed);
  1094. emitjmp(C_Z,constructorfailed);
  1095. emit_reg(A_PUSH,S_L,R_ESI);
  1096. new(r);
  1097. reset_reference(r^);
  1098. r^.base:=R_ESI;
  1099. getexplicitregister32(R_EDI);
  1100. emit_ref_reg(A_MOV,S_L,r,R_EDI);
  1101. new(r);
  1102. reset_reference(r^);
  1103. r^.offset:=68;
  1104. r^.base:=R_EDI;
  1105. emit_ref(A_CALL,S_NO,r);
  1106. ungetregister32(R_EDI);
  1107. exprasmList.concat(Tairegalloc.Alloc(R_EAX));
  1108. emitlab(constructorfailed);
  1109. emit_reg_reg(A_MOV,S_L,R_ESI,R_EAX);
  1110. end;
  1111. { handle function results }
  1112. { structured results are easy to handle.... }
  1113. { needed also when result_no_used !! }
  1114. if (not is_void(resulttype.def)) and ret_in_param(resulttype.def) then
  1115. begin
  1116. location.loc:=LOC_MEM;
  1117. location.reference.symbol:=nil;
  1118. location.reference:=funcretref;
  1119. end;
  1120. { we have only to handle the result if it is used, but }
  1121. { ansi/widestrings must be registered, so we can dispose them }
  1122. if (not is_void(resulttype.def)) and ((nf_return_value_used in flags) or
  1123. is_ansistring(resulttype.def) or is_widestring(resulttype.def)) then
  1124. begin
  1125. { a contructor could be a function with boolean result }
  1126. if (inlined or
  1127. (right=nil)) and
  1128. (procdefinition.proctypeoption=potype_constructor) and
  1129. { quick'n'dirty check if it is a class or an object }
  1130. (resulttype.def.deftype=orddef) then
  1131. begin
  1132. { this fails if popsize > 0 PM }
  1133. location.loc:=LOC_FLAGS;
  1134. location.resflags:=F_NE;
  1135. if extended_new then
  1136. begin
  1137. {$ifdef test_dest_loc}
  1138. if dest_loc_known and (dest_loc_tree=p) then
  1139. mov_reg_to_dest(p,S_L,R_EAX)
  1140. else
  1141. {$endif test_dest_loc}
  1142. begin
  1143. hregister:=getexplicitregister32(R_EAX);
  1144. emit_reg_reg(A_MOV,S_L,R_EAX,hregister);
  1145. location.register:=hregister;
  1146. end;
  1147. end;
  1148. end
  1149. { structed results are easy to handle.... }
  1150. else if ret_in_param(resulttype.def) then
  1151. begin
  1152. {location.loc:=LOC_MEM;
  1153. stringdispose(location.reference.symbol);
  1154. location.reference:=funcretref;
  1155. already done above (PM) }
  1156. end
  1157. else
  1158. begin
  1159. if (resulttype.def.deftype in [orddef,enumdef]) then
  1160. begin
  1161. location.loc:=LOC_REGISTER;
  1162. case resulttype.def.size of
  1163. 4 :
  1164. begin
  1165. {$ifdef test_dest_loc}
  1166. if dest_loc_known and (dest_loc_tree=p) then
  1167. mov_reg_to_dest(p,S_L,R_EAX)
  1168. else
  1169. {$endif test_dest_loc}
  1170. begin
  1171. hregister:=getexplicitregister32(R_EAX);
  1172. emit_reg_reg(A_MOV,S_L,R_EAX,hregister);
  1173. location.register:=hregister;
  1174. end;
  1175. end;
  1176. 1 :
  1177. begin
  1178. {$ifdef test_dest_loc}
  1179. if dest_loc_known and (dest_loc_tree=p) then
  1180. mov_reg_to_dest(p,S_B,R_AL)
  1181. else
  1182. {$endif test_dest_loc}
  1183. begin
  1184. hregister:=getexplicitregister32(R_EAX);
  1185. emit_reg_reg(A_MOV,S_B,R_AL,reg32toreg8(hregister));
  1186. location.register:=reg32toreg8(hregister);
  1187. end;
  1188. end;
  1189. 2 :
  1190. begin
  1191. {$ifdef test_dest_loc}
  1192. if dest_loc_known and (dest_loc_tree=p) then
  1193. mov_reg_to_dest(p,S_W,R_AX)
  1194. else
  1195. {$endif test_dest_loc}
  1196. begin
  1197. hregister:=getexplicitregister32(R_EAX);
  1198. emit_reg_reg(A_MOV,S_W,R_AX,reg32toreg16(hregister));
  1199. location.register:=reg32toreg16(hregister);
  1200. end;
  1201. end;
  1202. 8 :
  1203. begin
  1204. {$ifdef test_dest_loc}
  1205. {$error Don't know what to do here}
  1206. {$endif test_dest_loc}
  1207. if R_EDX in unused then
  1208. begin
  1209. hregister2:=getexplicitregister32(R_EDX);
  1210. hregister:=getexplicitregister32(R_EAX);
  1211. end
  1212. else
  1213. begin
  1214. hregister:=getexplicitregister32(R_EAX);
  1215. hregister2:=getexplicitregister32(R_EDX);
  1216. end;
  1217. emit_reg_reg(A_MOV,S_L,R_EAX,hregister);
  1218. emit_reg_reg(A_MOV,S_L,R_EDX,hregister2);
  1219. location.registerlow:=hregister;
  1220. location.registerhigh:=hregister2;
  1221. end;
  1222. else internalerror(7);
  1223. end
  1224. end
  1225. else if (resulttype.def.deftype=floatdef) then
  1226. begin
  1227. location.loc:=LOC_FPU;
  1228. inc(fpuvaroffset);
  1229. end
  1230. else if is_ansistring(resulttype.def) or
  1231. is_widestring(resulttype.def) then
  1232. begin
  1233. emit_reg_ref(A_MOV,S_L,R_EAX,
  1234. newreference(refcountedtemp));
  1235. location.loc:=LOC_MEM;
  1236. location.reference:=refcountedtemp;
  1237. end
  1238. else
  1239. begin
  1240. location.loc:=LOC_REGISTER;
  1241. {$ifdef test_dest_loc}
  1242. if dest_loc_known and (dest_loc_tree=p) then
  1243. mov_reg_to_dest(p,S_L,R_EAX)
  1244. else
  1245. {$endif test_dest_loc}
  1246. begin
  1247. hregister:=getexplicitregister32(R_EAX);
  1248. emit_reg_reg(A_MOV,S_L,R_EAX,hregister);
  1249. location.register:=hregister;
  1250. end;
  1251. end;
  1252. end;
  1253. end;
  1254. { perhaps i/o check ? }
  1255. if iolabel<>nil then
  1256. begin
  1257. emit_sym(A_PUSH,S_L,iolabel);
  1258. emitcall('FPC_IOCHECK');
  1259. end;
  1260. if pop_size>0 then
  1261. emit_const_reg(A_ADD,S_L,pop_size,R_ESP);
  1262. { restore registers }
  1263. popusedregisters(pushed);
  1264. { at last, restore instance pointer (SELF) }
  1265. if loadesi then
  1266. maybe_loadself;
  1267. pp:=tbinarynode(params);
  1268. while assigned(pp) do
  1269. begin
  1270. if assigned(pp.left) then
  1271. begin
  1272. if (pp.left.location.loc in [LOC_REFERENCE,LOC_MEM]) then
  1273. ungetiftemp(pp.left.location.reference);
  1274. { process also all nodes of an array of const }
  1275. if pp.left.nodetype=arrayconstructorn then
  1276. begin
  1277. if assigned(tarrayconstructornode(pp.left).left) then
  1278. begin
  1279. hp:=pp.left;
  1280. while assigned(hp) do
  1281. begin
  1282. if (tarrayconstructornode(tunarynode(hp).left).location.loc in [LOC_REFERENCE,LOC_MEM]) then
  1283. ungetiftemp(tarrayconstructornode(hp).left.location.reference);
  1284. hp:=tbinarynode(hp).right;
  1285. end;
  1286. end;
  1287. end;
  1288. end;
  1289. pp:=tbinarynode(pp.right);
  1290. end;
  1291. if inlined then
  1292. begin
  1293. ungetpersistanttemp(inlinecode.retoffset);
  1294. tprocdef(procdefinition).parast.address_fixup:=store_parast_fixup;
  1295. right:=inlinecode;
  1296. end;
  1297. if assigned(params) then
  1298. params.free;
  1299. { from now on the result can be freed normally }
  1300. if inlined and ret_in_param(resulttype.def) then
  1301. persistanttemptonormal(funcretref.offset);
  1302. { if return value is not used }
  1303. if (not(nf_return_value_used in flags)) and (not is_void(resulttype.def)) then
  1304. begin
  1305. if location.loc in [LOC_MEM,LOC_REFERENCE] then
  1306. begin
  1307. { data which must be finalized ? }
  1308. if (resulttype.def.needs_inittable) then
  1309. finalize(resulttype.def,location.reference,false);
  1310. { release unused temp }
  1311. ungetiftemp(location.reference)
  1312. end
  1313. else if location.loc=LOC_FPU then
  1314. begin
  1315. { release FPU stack }
  1316. emit_reg(A_FSTP,S_NO,R_ST0);
  1317. {
  1318. dec(fpuvaroffset);
  1319. do NOT decrement as the increment before
  1320. is not called for unused results PM }
  1321. end;
  1322. end;
  1323. end;
  1324. {*****************************************************************************
  1325. TI386PROCINLINENODE
  1326. *****************************************************************************}
  1327. procedure ti386procinlinenode.pass_2;
  1328. var st : tsymtable;
  1329. oldprocdef : tprocdef;
  1330. ps, i : longint;
  1331. tmpreg: tregister;
  1332. oldprocinfo : pprocinfo;
  1333. oldinlining_procedure,
  1334. nostackframe,make_global : boolean;
  1335. inlineentrycode,inlineexitcode : TAAsmoutput;
  1336. oldexitlabel,oldexit2label,oldquickexitlabel:tasmlabel;
  1337. oldunused,oldusableregs : tregisterset;
  1338. oldc_usableregs : longint;
  1339. oldreg_pushes : regvar_longintarray;
  1340. oldregvar_loaded,
  1341. oldis_reg_var : regvar_booleanarray;
  1342. {$ifdef TEMPREGDEBUG}
  1343. oldreg_user : regvar_ptreearray;
  1344. oldreg_releaser : regvar_ptreearray;
  1345. {$endif TEMPREGDEBUG}
  1346. {$ifdef GDB}
  1347. startlabel,endlabel : tasmlabel;
  1348. pp : pchar;
  1349. mangled_length : longint;
  1350. {$endif GDB}
  1351. begin
  1352. { deallocate the registers used for the current procedure's regvars }
  1353. if assigned(aktprocdef.regvarinfo) then
  1354. begin
  1355. with pregvarinfo(aktprocdef.regvarinfo)^ do
  1356. for i := 1 to maxvarregs do
  1357. if assigned(regvars[i]) then
  1358. store_regvar(exprasmlist,regvars[i].reg);
  1359. oldunused := unused;
  1360. oldusableregs := usableregs;
  1361. oldc_usableregs := c_usableregs;
  1362. oldreg_pushes := reg_pushes;
  1363. oldis_reg_var := is_reg_var;
  1364. oldregvar_loaded := regvar_loaded;
  1365. {$ifdef TEMPREGDEBUG}
  1366. oldreg_user := reg_user;
  1367. oldreg_releaser := reg_releaser;
  1368. {$endif TEMPREGDEBUG}
  1369. { make sure the register allocator knows what the regvars in the }
  1370. { inlined code block are (JM) }
  1371. resetusableregisters;
  1372. clearregistercount;
  1373. cleartempgen;
  1374. if assigned(inlineprocdef.regvarinfo) then
  1375. with pregvarinfo(inlineprocdef.regvarinfo)^ do
  1376. for i := 1 to maxvarregs do
  1377. if assigned(regvars[i]) then
  1378. begin
  1379. case regsize(regvars[i].reg) of
  1380. S_B: tmpreg := reg8toreg32(regvars[i].reg);
  1381. S_W: tmpreg := reg16toreg32(regvars[i].reg);
  1382. S_L: tmpreg := regvars[i].reg;
  1383. end;
  1384. usableregs:=usableregs-[tmpreg];
  1385. is_reg_var[tmpreg]:=true;
  1386. dec(c_usableregs);
  1387. end;
  1388. end;
  1389. oldinlining_procedure:=inlining_procedure;
  1390. oldexitlabel:=aktexitlabel;
  1391. oldexit2label:=aktexit2label;
  1392. oldquickexitlabel:=quickexitlabel;
  1393. getlabel(aktexitlabel);
  1394. getlabel(aktexit2label);
  1395. { we're inlining a procedure }
  1396. inlining_procedure:=true;
  1397. { save old procinfo }
  1398. oldprocdef:=aktprocdef;
  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. inlineprocdef.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.41 2002-03-04 19:10:13 peter
  1521. * removed compiler warnings
  1522. Revision 1.40 2001/12/31 09:53:15 jonas
  1523. * changed remaining "getregister32" calls to "getregisterint"
  1524. Revision 1.39 2001/12/29 15:32:13 jonas
  1525. * powerpc/cgcpu.pas compiles :)
  1526. * several powerpc-related fixes
  1527. * cpuasm unit is now based on common tainst unit
  1528. + nppcmat unit for powerpc (almost complete)
  1529. Revision 1.38 2001/11/18 00:00:34 florian
  1530. * handling of ansi- and widestring results improved
  1531. Revision 1.37 2001/11/02 23:24:40 peter
  1532. * fixed crash with inlining after aktprocdef change
  1533. Revision 1.36 2001/11/02 22:58:09 peter
  1534. * procsym definition rewrite
  1535. Revision 1.35 2001/10/25 21:22:41 peter
  1536. * calling convention rewrite
  1537. Revision 1.34 2001/10/21 12:33:07 peter
  1538. * array access for properties added
  1539. Revision 1.33 2001/09/09 08:50:15 jonas
  1540. * when calling an inline procedure inside a nested procedure, the
  1541. framepointer was being pushed on the stack, but this pushed framepointer
  1542. was never used nor removed from the stack again after the inlining was
  1543. done. It's now simply not pushed anymore, because the inlined procedure
  1544. can get the previous framepointer from the procedure in which it is being
  1545. inlined (merged)
  1546. Revision 1.32 2001/09/01 23:02:30 jonas
  1547. * i386*: call and jmp read their first operand
  1548. * cgcal: deallocate hlper register only after call statement (fixes bug
  1549. with "procedure of object" and optimizer reported to bugrep on
  1550. 2001/08/30) ('merged')
  1551. Revision 1.31 2001/08/29 12:18:08 jonas
  1552. + new createinternres() constructor for tcallnode to support setting a
  1553. custom resulttype
  1554. * compilerproc typeconversions now set the resulttype from the type
  1555. conversion for the generated call node, because the resulttype of
  1556. of the compilerproc helper isn't always exact (e.g. the ones that
  1557. return shortstrings, actually return a shortstring[x], where x is
  1558. specified by the typeconversion node)
  1559. * ti386callnode.pass_2 now always uses resulttype instead of
  1560. procsym.definition.rettype (so the custom resulttype, if any, is
  1561. always used). Note that this "rettype" stuff is only for use with
  1562. compilerprocs.
  1563. Revision 1.30 2001/08/26 13:36:56 florian
  1564. * some cg reorganisation
  1565. * some PPC updates
  1566. Revision 1.29 2001/08/19 21:11:21 florian
  1567. * some bugs fix:
  1568. - overload; with external procedures fixed
  1569. - better selection of routine to do an overloaded
  1570. type case
  1571. - ... some more
  1572. Revision 1.28 2001/08/06 21:40:50 peter
  1573. * funcret moved from tprocinfo to tprocdef
  1574. Revision 1.27 2001/07/08 21:00:16 peter
  1575. * various widestring updates, it works now mostly without charset
  1576. mapping supported
  1577. Revision 1.26 2001/07/01 20:16:20 peter
  1578. * alignmentinfo record added
  1579. * -Oa argument supports more alignment settings that can be specified
  1580. per type: PROC,LOOP,VARMIN,VARMAX,CONSTMIN,CONSTMAX,RECORDMIN
  1581. RECORDMAX,LOCALMIN,LOCALMAX. It is possible to set the mimimum
  1582. required alignment and the maximum usefull alignment. The final
  1583. alignment will be choosen per variable size dependent on these
  1584. settings
  1585. Revision 1.25 2001/06/04 11:48:02 peter
  1586. * better const to var checking
  1587. Revision 1.24 2001/05/19 21:22:53 peter
  1588. * function returning int64 inlining fixed
  1589. Revision 1.23 2001/05/16 15:11:42 jonas
  1590. * added missign begin..end pair (noticed by Carl)
  1591. Revision 1.22 2001/04/18 22:02:01 peter
  1592. * registration of targets and assemblers
  1593. Revision 1.21 2001/04/13 01:22:18 peter
  1594. * symtable change to classes
  1595. * range check generation and errors fixed, make cycle DEBUG=1 works
  1596. * memory leaks fixed
  1597. Revision 1.20 2001/04/02 21:20:36 peter
  1598. * resulttype rewrite
  1599. Revision 1.19 2001/03/11 22:58:51 peter
  1600. * getsym redesign, removed the globals srsym,srsymtable
  1601. Revision 1.18 2001/01/27 21:29:35 florian
  1602. * behavior -Oa optimized
  1603. Revision 1.17 2001/01/08 21:46:46 peter
  1604. * don't push high value for open array with cdecl;external;
  1605. Revision 1.16 2000/12/25 00:07:32 peter
  1606. + new tlinkedlist class (merge of old tstringqueue,tcontainer and
  1607. tlinkedlist objects)
  1608. Revision 1.15 2000/12/09 10:45:40 florian
  1609. * AfterConstructor isn't called anymore when a constructor failed
  1610. Revision 1.14 2000/12/07 17:19:46 jonas
  1611. * new constant handling: from now on, hex constants >$7fffffff are
  1612. parsed as unsigned constants (otherwise, $80000000 got sign extended
  1613. and became $ffffffff80000000), all constants in the longint range
  1614. become longints, all constants >$7fffffff and <=cardinal($ffffffff)
  1615. are cardinals and the rest are int64's.
  1616. * added lots of longint typecast to prevent range check errors in the
  1617. compiler and rtl
  1618. * type casts of symbolic ordinal constants are now preserved
  1619. * fixed bug where the original resulttype.def wasn't restored correctly
  1620. after doing a 64bit rangecheck
  1621. Revision 1.13 2000/12/05 11:44:33 jonas
  1622. + new integer regvar handling, should be much more efficient
  1623. Revision 1.12 2000/12/03 22:26:54 florian
  1624. * fixed web buzg 1275: problem with int64 functions results
  1625. Revision 1.11 2000/11/29 00:30:46 florian
  1626. * unused units removed from uses clause
  1627. * some changes for widestrings
  1628. Revision 1.10 2000/11/23 13:26:34 jonas
  1629. * fix for webbug 1066/1126
  1630. Revision 1.9 2000/11/22 15:12:06 jonas
  1631. * fixed inline-related problems (partially "merges")
  1632. Revision 1.8 2000/11/17 09:54:58 florian
  1633. * INT_CHECK_OBJECT_* isn't applied to interfaces anymore
  1634. Revision 1.7 2000/11/12 23:24:14 florian
  1635. * interfaces are basically running
  1636. Revision 1.6 2000/11/07 23:40:49 florian
  1637. + AfterConstruction and BeforeDestruction impemented
  1638. Revision 1.5 2000/11/06 23:15:01 peter
  1639. * added copyvaluepara call again
  1640. Revision 1.4 2000/11/04 14:25:23 florian
  1641. + merged Attila's changes for interfaces, not tested yet
  1642. Revision 1.3 2000/11/04 13:12:14 jonas
  1643. * check for nil pointers before calling getcopy
  1644. Revision 1.2 2000/10/31 22:02:56 peter
  1645. * symtable splitted, no real code changes
  1646. Revision 1.1 2000/10/15 09:33:31 peter
  1647. * moved n386*.pas to i386/ cpu_target dir
  1648. Revision 1.2 2000/10/14 10:14:48 peter
  1649. * moehrendorf oct 2000 rewrite
  1650. Revision 1.1 2000/10/10 17:31:56 florian
  1651. * initial revision
  1652. }