tcmem.pas 23 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651
  1. {
  2. $Id$
  3. Copyright (c) 1998-2000 by Florian Klaempfl
  4. Type checking and register allocation for memory related 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 by
  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 tcmem;
  19. interface
  20. uses
  21. tree;
  22. procedure firstloadvmt(var p : ptree);
  23. procedure firsthnew(var p : ptree);
  24. procedure firstnew(var p : ptree);
  25. procedure firsthdispose(var p : ptree);
  26. procedure firstsimplenewdispose(var p : ptree);
  27. procedure firstaddr(var p : ptree);
  28. procedure firstdoubleaddr(var p : ptree);
  29. procedure firstderef(var p : ptree);
  30. procedure firstsubscript(var p : ptree);
  31. procedure firstvec(var p : ptree);
  32. procedure firstself(var p : ptree);
  33. procedure firstwith(var p : ptree);
  34. implementation
  35. uses
  36. globtype,systems,
  37. cobjects,verbose,globals,
  38. symconst,symtable,aasm,types,
  39. htypechk,pass_1,cpubase
  40. {$ifdef newcg}
  41. ,cgbase
  42. {$else newcg}
  43. ,hcodegen
  44. {$endif newcg}
  45. ;
  46. {*****************************************************************************
  47. FirstLoadVMT
  48. *****************************************************************************}
  49. procedure firstloadvmt(var p : ptree);
  50. begin
  51. p^.registers32:=1;
  52. p^.location.loc:=LOC_REGISTER;
  53. end;
  54. {*****************************************************************************
  55. FirstHNew
  56. *****************************************************************************}
  57. procedure firsthnew(var p : ptree);
  58. begin
  59. end;
  60. {*****************************************************************************
  61. FirstNewN
  62. *****************************************************************************}
  63. procedure firstnew(var p : ptree);
  64. begin
  65. { Standardeinleitung }
  66. if assigned(p^.left) then
  67. firstpass(p^.left);
  68. if codegenerror then
  69. exit;
  70. if assigned(p^.left) then
  71. begin
  72. p^.registers32:=p^.left^.registers32;
  73. p^.registersfpu:=p^.left^.registersfpu;
  74. {$ifdef SUPPORT_MMX}
  75. p^.registersmmx:=p^.left^.registersmmx;
  76. {$endif SUPPORT_MMX}
  77. end;
  78. { result type is already set }
  79. procinfo^.flags:=procinfo^.flags or pi_do_call;
  80. if assigned(p^.left) then
  81. p^.location.loc:=LOC_REGISTER
  82. else
  83. p^.location.loc:=LOC_REFERENCE;
  84. end;
  85. {*****************************************************************************
  86. FirstDispose
  87. *****************************************************************************}
  88. procedure firsthdispose(var p : ptree);
  89. begin
  90. firstpass(p^.left);
  91. if codegenerror then
  92. exit;
  93. p^.registers32:=p^.left^.registers32;
  94. p^.registersfpu:=p^.left^.registersfpu;
  95. {$ifdef SUPPORT_MMX}
  96. p^.registersmmx:=p^.left^.registersmmx;
  97. {$endif SUPPORT_MMX}
  98. if p^.registers32<1 then
  99. p^.registers32:=1;
  100. {
  101. if p^.left^.location.loc<>LOC_REFERENCE then
  102. CGMessage(cg_e_illegal_expression);
  103. }
  104. if p^.left^.location.loc=LOC_CREGISTER then
  105. inc(p^.registers32);
  106. p^.location.loc:=LOC_REFERENCE;
  107. p^.resulttype:=ppointerdef(p^.left^.resulttype)^.pointertype.def;
  108. end;
  109. {*****************************************************************************
  110. FirstSimpleNewDispose
  111. *****************************************************************************}
  112. procedure firstsimplenewdispose(var p : ptree);
  113. begin
  114. { this cannot be in a register !! }
  115. make_not_regable(p^.left);
  116. firstpass(p^.left);
  117. if codegenerror then
  118. exit;
  119. { check the type }
  120. if p^.left^.resulttype=nil then
  121. p^.left^.resulttype:=generrordef;
  122. if (p^.left^.resulttype^.deftype<>pointerdef) then
  123. CGMessage1(type_e_pointer_type_expected,p^.left^.resulttype^.typename);
  124. if (p^.left^.location.loc<>LOC_REFERENCE) {and
  125. (p^.left^.location.loc<>LOC_CREGISTER)} then
  126. CGMessage(cg_e_illegal_expression);
  127. p^.registers32:=p^.left^.registers32;
  128. p^.registersfpu:=p^.left^.registersfpu;
  129. {$ifdef SUPPORT_MMX}
  130. p^.registersmmx:=p^.left^.registersmmx;
  131. {$endif SUPPORT_MMX}
  132. p^.resulttype:=voiddef;
  133. procinfo^.flags:=procinfo^.flags or pi_do_call;
  134. end;
  135. {*****************************************************************************
  136. FirstAddr
  137. *****************************************************************************}
  138. procedure firstaddr(var p : ptree);
  139. var
  140. hp : ptree;
  141. hp2 : pparaitem;
  142. hp3 : pabstractprocdef;
  143. begin
  144. make_not_regable(p^.left);
  145. if not(assigned(p^.resulttype)) then
  146. begin
  147. { tp @procvar support (type of @procvar is a void pointer)
  148. Note: we need to leave the addrn in the tree,
  149. else we can't see the difference between @procvar and procvar.
  150. we set the procvarload flag so a secondpass does nothing for
  151. this node (PFV) }
  152. if (m_tp_procvar in aktmodeswitches) then
  153. begin
  154. hp:=p^.left;
  155. case hp^.treetype of
  156. calln :
  157. begin
  158. { is it a procvar? }
  159. hp:=hp^.right;
  160. if assigned(hp) then
  161. begin
  162. { remove calln node }
  163. putnode(p^.left);
  164. p^.left:=hp;
  165. firstpass(hp);
  166. p^.procvarload:=true;
  167. end;
  168. end;
  169. loadn,
  170. subscriptn,
  171. typeconvn,
  172. vecn,
  173. derefn :
  174. begin
  175. firstpass(hp);
  176. if codegenerror then
  177. exit;
  178. if hp^.resulttype^.deftype=procvardef then
  179. begin
  180. p^.procvarload:=true;
  181. end;
  182. end;
  183. end;
  184. end;
  185. if p^.procvarload then
  186. begin
  187. p^.registers32:=p^.left^.registers32;
  188. p^.registersfpu:=p^.left^.registersfpu;
  189. {$ifdef SUPPORT_MMX}
  190. p^.registersmmx:=p^.left^.registersmmx;
  191. {$endif SUPPORT_MMX}
  192. if p^.registers32<1 then
  193. p^.registers32:=1;
  194. p^.location.loc:=p^.left^.location.loc;
  195. p^.resulttype:=voidpointerdef;
  196. exit;
  197. end;
  198. { proc 2 procvar ? }
  199. if p^.left^.treetype=calln then
  200. begin
  201. { generate a methodcallnode or proccallnode }
  202. { we shouldn't convert things like @tcollection.load }
  203. if (p^.left^.symtableprocentry^.owner^.symtabletype=objectsymtable) and
  204. not(assigned(p^.left^.methodpointer) and (p^.left^.methodpointer^.treetype=typen)) then
  205. begin
  206. hp:=genloadmethodcallnode(pprocsym(p^.left^.symtableprocentry),p^.left^.symtableproc,
  207. getcopy(p^.left^.methodpointer));
  208. disposetree(p);
  209. firstpass(hp);
  210. p:=hp;
  211. exit;
  212. end
  213. else
  214. hp:=genloadcallnode(pprocsym(p^.left^.symtableprocentry),p^.left^.symtableproc);
  215. { result is a procedure variable }
  216. { No, to be TP compatible, you must return a pointer to
  217. the procedure that is stored in the procvar.}
  218. if not(m_tp_procvar in aktmodeswitches) then
  219. begin
  220. p^.resulttype:=new(pprocvardef,init);
  221. { it could also be a procvar, not only pprocsym ! }
  222. if p^.left^.symtableprocentry^.typ=varsym then
  223. hp3:=pabstractprocdef(pvarsym(p^.left^.symtableentry)^.vartype.def)
  224. else
  225. hp3:=pabstractprocdef(pprocsym(p^.left^.symtableprocentry)^.definition);
  226. pprocvardef(p^.resulttype)^.proctypeoption:=hp3^.proctypeoption;
  227. pprocvardef(p^.resulttype)^.proccalloptions:=hp3^.proccalloptions;
  228. pprocvardef(p^.resulttype)^.procoptions:=hp3^.procoptions;
  229. pprocvardef(p^.resulttype)^.rettype:=hp3^.rettype;
  230. pprocvardef(p^.resulttype)^.symtablelevel:=hp3^.symtablelevel;
  231. { method ? then set the methodpointer flag }
  232. if (hp3^.owner^.symtabletype=objectsymtable) and
  233. (pobjectdef(hp3^.owner^.defowner)^.is_class) then
  234. include(pprocvardef(p^.resulttype)^.procoptions,po_methodpointer);
  235. { we need to process the parameters reverse so they are inserted
  236. in the correct right2left order (PFV) }
  237. hp2:=pparaitem(hp3^.para^.last);
  238. while assigned(hp2) do
  239. begin
  240. pprocvardef(p^.resulttype)^.concatpara(hp2^.paratype,hp2^.paratyp);
  241. hp2:=pparaitem(hp2^.previous);
  242. end;
  243. end
  244. else
  245. p^.resulttype:=voidpointerdef;
  246. disposetree(p^.left);
  247. p^.left:=hp;
  248. end
  249. else
  250. begin
  251. firstpass(p^.left);
  252. { what are we getting the address from an absolute sym? }
  253. hp:=p^.left;
  254. while assigned(hp) and (hp^.treetype in [vecn,derefn,subscriptn]) do
  255. hp:=hp^.left;
  256. if assigned(hp) and (hp^.treetype=loadn) and
  257. ((hp^.symtableentry^.typ=absolutesym) and
  258. pabsolutesym(hp^.symtableentry)^.absseg) then
  259. begin
  260. if not(cs_typed_addresses in aktlocalswitches) then
  261. p^.resulttype:=voidfarpointerdef
  262. else
  263. p^.resulttype:=new(ppointerdef,initfardef(p^.left^.resulttype));
  264. end
  265. else
  266. begin
  267. if not(cs_typed_addresses in aktlocalswitches) then
  268. p^.resulttype:=voidpointerdef
  269. else
  270. p^.resulttype:=new(ppointerdef,initdef(p^.left^.resulttype));
  271. end;
  272. end;
  273. end;
  274. firstpass(p^.left);
  275. { this is like the function addr }
  276. inc(parsing_para_level);
  277. set_varstate(p^.left,false);
  278. dec(parsing_para_level);
  279. if codegenerror then
  280. exit;
  281. { don't allow constants }
  282. if is_constnode(p^.left) then
  283. begin
  284. aktfilepos:=p^.left^.fileinfo;
  285. CGMessage(type_e_no_addr_of_constant);
  286. end
  287. else
  288. begin
  289. { we should allow loc_mem for @string }
  290. if not(p^.left^.location.loc in [LOC_MEM,LOC_REFERENCE]) then
  291. begin
  292. aktfilepos:=p^.left^.fileinfo;
  293. CGMessage(cg_e_illegal_expression);
  294. end;
  295. end;
  296. p^.registers32:=p^.left^.registers32;
  297. p^.registersfpu:=p^.left^.registersfpu;
  298. {$ifdef SUPPORT_MMX}
  299. p^.registersmmx:=p^.left^.registersmmx;
  300. {$endif SUPPORT_MMX}
  301. if p^.registers32<1 then
  302. p^.registers32:=1;
  303. { is this right for object of methods ?? }
  304. p^.location.loc:=LOC_REGISTER;
  305. end;
  306. {*****************************************************************************
  307. FirstDoubleAddr
  308. *****************************************************************************}
  309. procedure firstdoubleaddr(var p : ptree);
  310. begin
  311. make_not_regable(p^.left);
  312. firstpass(p^.left);
  313. inc(parsing_para_level);
  314. set_varstate(p^.left,false);
  315. dec(parsing_para_level);
  316. if p^.resulttype=nil then
  317. p^.resulttype:=voidpointerdef;
  318. if codegenerror then
  319. exit;
  320. if (p^.left^.resulttype^.deftype)<>procvardef then
  321. CGMessage(cg_e_illegal_expression);
  322. if (p^.left^.location.loc<>LOC_REFERENCE) then
  323. CGMessage(cg_e_illegal_expression);
  324. p^.registers32:=p^.left^.registers32;
  325. p^.registersfpu:=p^.left^.registersfpu;
  326. {$ifdef SUPPORT_MMX}
  327. p^.registersmmx:=p^.left^.registersmmx;
  328. {$endif SUPPORT_MMX}
  329. if p^.registers32<1 then
  330. p^.registers32:=1;
  331. p^.location.loc:=LOC_REGISTER;
  332. end;
  333. {*****************************************************************************
  334. FirstDeRef
  335. *****************************************************************************}
  336. procedure firstderef(var p : ptree);
  337. begin
  338. firstpass(p^.left);
  339. set_varstate(p^.left,true);
  340. if codegenerror then
  341. begin
  342. p^.resulttype:=generrordef;
  343. exit;
  344. end;
  345. p^.registers32:=max(p^.left^.registers32,1);
  346. p^.registersfpu:=p^.left^.registersfpu;
  347. {$ifdef SUPPORT_MMX}
  348. p^.registersmmx:=p^.left^.registersmmx;
  349. {$endif SUPPORT_MMX}
  350. if p^.left^.resulttype^.deftype<>pointerdef then
  351. CGMessage(cg_e_invalid_qualifier);
  352. p^.resulttype:=ppointerdef(p^.left^.resulttype)^.pointertype.def;
  353. p^.location.loc:=LOC_REFERENCE;
  354. end;
  355. {*****************************************************************************
  356. FirstSubScript
  357. *****************************************************************************}
  358. procedure firstsubscript(var p : ptree);
  359. begin
  360. firstpass(p^.left);
  361. if codegenerror then
  362. begin
  363. p^.resulttype:=generrordef;
  364. exit;
  365. end;
  366. p^.resulttype:=p^.vs^.vartype.def;
  367. p^.registers32:=p^.left^.registers32;
  368. p^.registersfpu:=p^.left^.registersfpu;
  369. {$ifdef SUPPORT_MMX}
  370. p^.registersmmx:=p^.left^.registersmmx;
  371. {$endif SUPPORT_MMX}
  372. { classes must be dereferenced implicit }
  373. if (p^.left^.resulttype^.deftype=objectdef) and
  374. pobjectdef(p^.left^.resulttype)^.is_class then
  375. begin
  376. if p^.registers32=0 then
  377. p^.registers32:=1;
  378. p^.location.loc:=LOC_REFERENCE;
  379. end
  380. else
  381. begin
  382. if (p^.left^.location.loc<>LOC_MEM) and
  383. (p^.left^.location.loc<>LOC_REFERENCE) then
  384. CGMessage(cg_e_illegal_expression);
  385. set_location(p^.location,p^.left^.location);
  386. end;
  387. end;
  388. {*****************************************************************************
  389. FirstVec
  390. *****************************************************************************}
  391. procedure firstvec(var p : ptree);
  392. var
  393. harr : pdef;
  394. ct : tconverttype;
  395. {$ifdef consteval}
  396. tcsym : ptypedconstsym;
  397. {$endif}
  398. begin
  399. firstpass(p^.left);
  400. firstpass(p^.right);
  401. if codegenerror then
  402. exit;
  403. { range check only for arrays }
  404. if (p^.left^.resulttype^.deftype=arraydef) then
  405. begin
  406. if (isconvertable(p^.right^.resulttype,parraydef(p^.left^.resulttype)^.rangetype.def,
  407. ct,ordconstn,false)=0) and
  408. not(is_equal(p^.right^.resulttype,parraydef(p^.left^.resulttype)^.rangetype.def)) then
  409. CGMessage(type_e_mismatch);
  410. end;
  411. { Never convert a boolean or a char !}
  412. { maybe type conversion }
  413. if (p^.right^.resulttype^.deftype<>enumdef) and
  414. not(is_char(p^.right^.resulttype)) and
  415. not(is_boolean(p^.right^.resulttype)) then
  416. begin
  417. p^.right:=gentypeconvnode(p^.right,s32bitdef);
  418. firstpass(p^.right);
  419. if codegenerror then
  420. exit;
  421. end;
  422. { are we accessing a pointer[], then convert the pointer to
  423. an array first }
  424. if (p^.left^.resulttype^.deftype=pointerdef) then
  425. begin
  426. { convert pointer to array }
  427. harr:=new(parraydef,init(0,$7fffffff,s32bitdef));
  428. parraydef(harr)^.elementtype.def:=ppointerdef(p^.left^.resulttype)^.pointertype.def;
  429. p^.left:=gentypeconvnode(p^.left,harr);
  430. firstpass(p^.left);
  431. if codegenerror then
  432. exit;
  433. p^.resulttype:=parraydef(harr)^.elementtype.def
  434. end;
  435. { determine return type }
  436. if not assigned(p^.resulttype) then
  437. if p^.left^.resulttype^.deftype=arraydef then
  438. p^.resulttype:=parraydef(p^.left^.resulttype)^.elementtype.def
  439. else if p^.left^.resulttype^.deftype=stringdef then
  440. begin
  441. { indexed access to strings }
  442. case pstringdef(p^.left^.resulttype)^.string_typ of
  443. {
  444. st_widestring : p^.resulttype:=cwchardef;
  445. }
  446. st_ansistring : p^.resulttype:=cchardef;
  447. st_longstring : p^.resulttype:=cchardef;
  448. st_shortstring : p^.resulttype:=cchardef;
  449. end;
  450. end
  451. else
  452. CGMessage(type_e_mismatch);
  453. { the register calculation is easy if a const index is used }
  454. if p^.right^.treetype=ordconstn then
  455. begin
  456. {$ifdef consteval}
  457. { constant evaluation }
  458. if (p^.left^.treetype=loadn) and
  459. (p^.left^.symtableentry^.typ=typedconstsym) then
  460. begin
  461. tcsym:=ptypedconstsym(p^.left^.symtableentry);
  462. if tcsym^.defintion^.typ=stringdef then
  463. begin
  464. end;
  465. end;
  466. {$endif}
  467. p^.registers32:=p^.left^.registers32;
  468. { for ansi/wide strings, we need at least one register }
  469. if is_ansistring(p^.left^.resulttype) or
  470. is_widestring(p^.left^.resulttype) then
  471. p^.registers32:=max(p^.registers32,1);
  472. end
  473. else
  474. begin
  475. { this rules are suboptimal, but they should give }
  476. { good results }
  477. p^.registers32:=max(p^.left^.registers32,p^.right^.registers32);
  478. { for ansi/wide strings, we need at least one register }
  479. if is_ansistring(p^.left^.resulttype) or
  480. is_widestring(p^.left^.resulttype) then
  481. p^.registers32:=max(p^.registers32,1);
  482. { need we an extra register when doing the restore ? }
  483. if (p^.left^.registers32<=p^.right^.registers32) and
  484. { only if the node needs less than 3 registers }
  485. { two for the right node and one for the }
  486. { left address }
  487. (p^.registers32<3) then
  488. inc(p^.registers32);
  489. { need we an extra register for the index ? }
  490. if (p^.right^.location.loc<>LOC_REGISTER)
  491. { only if the right node doesn't need a register }
  492. and (p^.right^.registers32<1) then
  493. inc(p^.registers32);
  494. { not correct, but what works better ?
  495. if p^.left^.registers32>0 then
  496. p^.registers32:=max(p^.registers32,2)
  497. else
  498. min. one register
  499. p^.registers32:=max(p^.registers32,1);
  500. }
  501. end;
  502. p^.registersfpu:=max(p^.left^.registersfpu,p^.right^.registersfpu);
  503. {$ifdef SUPPORT_MMX}
  504. p^.registersmmx:=max(p^.left^.registersmmx,p^.right^.registersmmx);
  505. {$endif SUPPORT_MMX}
  506. if p^.left^.location.loc in [LOC_CREGISTER,LOC_REFERENCE] then
  507. p^.location.loc:=LOC_REFERENCE
  508. else
  509. p^.location.loc:=LOC_MEM;
  510. end;
  511. {*****************************************************************************
  512. FirstSelf
  513. *****************************************************************************}
  514. procedure firstself(var p : ptree);
  515. begin
  516. if (p^.resulttype^.deftype=classrefdef) or
  517. ((p^.resulttype^.deftype=objectdef)
  518. and pobjectdef(p^.resulttype)^.is_class
  519. ) then
  520. p^.location.loc:=LOC_CREGISTER
  521. else
  522. p^.location.loc:=LOC_REFERENCE;
  523. end;
  524. {*****************************************************************************
  525. FirstWithN
  526. *****************************************************************************}
  527. procedure firstwith(var p : ptree);
  528. var
  529. symtable : pwithsymtable;
  530. i : longint;
  531. begin
  532. if assigned(p^.left) and assigned(p^.right) then
  533. begin
  534. firstpass(p^.left);
  535. { is this correct ? At least after is like if used
  536. set_varstate(p^.left,false);
  537. already done in _with_statment }
  538. p^.left^.varstateset:=false;
  539. set_varstate(p^.left,true);
  540. if codegenerror then
  541. exit;
  542. symtable:=p^.withsymtable;
  543. for i:=1 to p^.tablecount do
  544. begin
  545. if (p^.left^.treetype=loadn) and
  546. (p^.left^.symtable=aktprocsym^.definition^.localst) then
  547. symtable^.direct_with:=true;
  548. symtable^.withnode:=p;
  549. symtable:=pwithsymtable(symtable^.next);
  550. end;
  551. firstpass(p^.right);
  552. if codegenerror then
  553. exit;
  554. left_right_max(p);
  555. p^.resulttype:=voiddef;
  556. end
  557. else
  558. begin
  559. { optimization }
  560. disposetree(p);
  561. p:=nil;
  562. end;
  563. end;
  564. end.
  565. {
  566. $Log$
  567. Revision 1.3 2000-07-13 12:08:28 michael
  568. + patched to 1.1.0 with former 1.09patch from peter
  569. Revision 1.2 2000/07/13 11:32:52 michael
  570. + removed logs
  571. }