nmat.pas 20 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656
  1. {
  2. $Id$
  3. Copyright (c) 2000 by Florian Klaempfl
  4. Type checking and register allocation for math 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 nmat;
  19. {$i defines.inc}
  20. interface
  21. uses
  22. node;
  23. type
  24. tmoddivnode = class(tbinopnode)
  25. function pass_1 : tnode;override;
  26. function det_resulttype:tnode;override;
  27. end;
  28. tshlshrnode = class(tbinopnode)
  29. function pass_1 : tnode;override;
  30. function det_resulttype:tnode;override;
  31. end;
  32. tunaryminusnode = class(tunarynode)
  33. constructor create(expr : tnode);virtual;
  34. function pass_1 : tnode;override;
  35. function det_resulttype:tnode;override;
  36. end;
  37. tnotnode = class(tunarynode)
  38. constructor create(expr : tnode);virtual;
  39. function pass_1 : tnode;override;
  40. function det_resulttype:tnode;override;
  41. end;
  42. var
  43. cmoddivnode : class of tmoddivnode;
  44. cshlshrnode : class of tshlshrnode;
  45. cunaryminusnode : class of tunaryminusnode;
  46. cnotnode : class of tnotnode;
  47. implementation
  48. uses
  49. systems,tokens,
  50. verbose,globals,
  51. {$ifdef support_mmx}
  52. globtype,
  53. {$endif}
  54. symconst,symtype,symtable,symdef,types,
  55. htypechk,pass_1,cpubase,cpuinfo,
  56. {$ifdef newcg}
  57. cgbase,
  58. {$endif newcg}
  59. hcodegen,
  60. ncon,ncnv,ncal;
  61. {****************************************************************************
  62. TMODDIVNODE
  63. ****************************************************************************}
  64. function tmoddivnode.det_resulttype:tnode;
  65. var
  66. t : tnode;
  67. rd,ld : tdef;
  68. rv,lv : tconstexprint;
  69. begin
  70. result:=nil;
  71. resulttypepass(left);
  72. resulttypepass(right);
  73. set_varstate(left,true);
  74. set_varstate(right,true);
  75. if codegenerror then
  76. exit;
  77. { constant folding }
  78. if is_constintnode(left) and is_constintnode(right) then
  79. begin
  80. rv:=tordconstnode(right).value;
  81. lv:=tordconstnode(left).value;
  82. { check for division by zero }
  83. if (rv=0) then
  84. begin
  85. Message(parser_e_division_by_zero);
  86. { recover }
  87. rv:=1;
  88. end;
  89. case nodetype of
  90. modn:
  91. t:=genintconstnode(lv mod rv);
  92. divn:
  93. t:=genintconstnode(lv div rv);
  94. end;
  95. resulttypepass(t);
  96. result:=t;
  97. exit;
  98. end;
  99. { allow operator overloading }
  100. t:=self;
  101. if isbinaryoverloaded(t) then
  102. begin
  103. resulttypepass(t);
  104. result:=t;
  105. exit;
  106. end;
  107. { if one operand is a cardinal and the other is a positive constant, convert the }
  108. { constant to a cardinal as well so we don't have to do a 64bit division (JM) }
  109. { Do the same for qwords and positive constants as well, otherwise things like }
  110. { "qword mod 10" are evaluated with int64 as result, which is wrong if the }
  111. { "qword" was > high(int64) (JM) }
  112. if (left.resulttype.def.deftype=orddef) and (right.resulttype.def.deftype=orddef) then
  113. if (torddef(right.resulttype.def).typ in [u32bit,u64bit]) and
  114. is_constintnode(left) and
  115. (tordconstnode(left).value >= 0) then
  116. inserttypeconv(left,right.resulttype)
  117. else if (torddef(left.resulttype.def).typ in [u32bit,u64bit]) and
  118. is_constintnode(right) and
  119. (tordconstnode(right).value >= 0) then
  120. inserttypeconv(right,left.resulttype);
  121. if (left.resulttype.def.deftype=orddef) and (right.resulttype.def.deftype=orddef) and
  122. (is_64bitint(left.resulttype.def) or is_64bitint(right.resulttype.def) or
  123. { when mixing cardinals and signed numbers, convert everythign to 64bit (JM) }
  124. ((torddef(right.resulttype.def).typ = u32bit) and
  125. is_signed(left.resulttype.def)) or
  126. ((torddef(left.resulttype.def).typ = u32bit) and
  127. is_signed(right.resulttype.def))) then
  128. begin
  129. rd:=right.resulttype.def;
  130. ld:=left.resulttype.def;
  131. { issue warning if necessary }
  132. if not (is_64bitint(left.resulttype.def) or is_64bitint(right.resulttype.def)) then
  133. CGMessage(type_w_mixed_signed_unsigned);
  134. if is_signed(rd) or is_signed(ld) then
  135. begin
  136. if (torddef(ld).typ<>s64bit) then
  137. inserttypeconv(left,cs64bittype);
  138. if (torddef(rd).typ<>s64bit) then
  139. inserttypeconv(right,cs64bittype);
  140. end
  141. else
  142. begin
  143. if (torddef(ld).typ<>u64bit) then
  144. inserttypeconv(left,cu64bittype);
  145. if (torddef(rd).typ<>u64bit) then
  146. inserttypeconv(right,cu64bittype);
  147. end;
  148. resulttype:=left.resulttype;
  149. end
  150. else
  151. begin
  152. if not(right.resulttype.def.deftype=orddef) or
  153. not(torddef(right.resulttype.def).typ in [s32bit,u32bit]) then
  154. inserttypeconv(right,s32bittype);
  155. if not(left.resulttype.def.deftype=orddef) or
  156. not(torddef(left.resulttype.def).typ in [s32bit,u32bit]) then
  157. inserttypeconv(left,s32bittype);
  158. { the resulttype.def depends on the right side, because the left becomes }
  159. { always 64 bit }
  160. resulttype:=right.resulttype;
  161. end;
  162. end;
  163. function tmoddivnode.pass_1 : tnode;
  164. begin
  165. result:=nil;
  166. firstpass(left);
  167. firstpass(right);
  168. if codegenerror then
  169. exit;
  170. { 64bit }
  171. if (left.resulttype.def.deftype=orddef) and (right.resulttype.def.deftype=orddef) and
  172. (is_64bitint(left.resulttype.def) or is_64bitint(right.resulttype.def)) then
  173. begin
  174. calcregisters(self,2,0,0);
  175. end
  176. else
  177. begin
  178. left_right_max;
  179. if left.registers32<=right.registers32 then
  180. inc(registers32);
  181. end;
  182. location.loc:=LOC_REGISTER;
  183. end;
  184. {****************************************************************************
  185. TSHLSHRNODE
  186. ****************************************************************************}
  187. function tshlshrnode.det_resulttype:tnode;
  188. var
  189. t : tnode;
  190. begin
  191. result:=nil;
  192. resulttypepass(left);
  193. resulttypepass(right);
  194. set_varstate(right,true);
  195. set_varstate(left,true);
  196. if codegenerror then
  197. exit;
  198. { constant folding }
  199. if is_constintnode(left) and is_constintnode(right) then
  200. begin
  201. case nodetype of
  202. shrn:
  203. t:=genintconstnode(tordconstnode(left).value shr tordconstnode(right).value);
  204. shln:
  205. t:=genintconstnode(tordconstnode(left).value shl tordconstnode(right).value);
  206. end;
  207. resulttypepass(t);
  208. result:=t;
  209. exit;
  210. end;
  211. { allow operator overloading }
  212. t:=self;
  213. if isbinaryoverloaded(t) then
  214. begin
  215. resulttypepass(t);
  216. result:=t;
  217. exit;
  218. end;
  219. { 64 bit ints have their own shift handling }
  220. if not(is_64bitint(left.resulttype.def)) then
  221. begin
  222. if torddef(left.resulttype.def).typ <> u32bit then
  223. inserttypeconv(left,s32bittype);
  224. end;
  225. inserttypeconv(right,s32bittype);
  226. resulttype:=left.resulttype;
  227. end;
  228. function tshlshrnode.pass_1 : tnode;
  229. var
  230. regs : longint;
  231. begin
  232. result:=nil;
  233. firstpass(left);
  234. firstpass(right);
  235. if codegenerror then
  236. exit;
  237. { 64 bit ints have their own shift handling }
  238. if not(is_64bitint(left.resulttype.def)) then
  239. regs:=1
  240. else
  241. regs:=2;
  242. if (right.nodetype<>ordconstn) then
  243. inc(regs);
  244. calcregisters(self,regs,0,0);
  245. location.loc:=LOC_REGISTER;
  246. end;
  247. {****************************************************************************
  248. TUNARYMINUSNODE
  249. ****************************************************************************}
  250. constructor tunaryminusnode.create(expr : tnode);
  251. begin
  252. inherited create(unaryminusn,expr);
  253. end;
  254. function tunaryminusnode.det_resulttype : tnode;
  255. var
  256. t : tnode;
  257. minusdef : tprocdef;
  258. begin
  259. result:=nil;
  260. resulttypepass(left);
  261. set_varstate(left,true);
  262. if codegenerror then
  263. exit;
  264. { constant folding }
  265. if is_constintnode(left) then
  266. begin
  267. tordconstnode(left).value:=-tordconstnode(left).value;
  268. result:=left;
  269. left:=nil;
  270. exit;
  271. end;
  272. if is_constrealnode(left) then
  273. begin
  274. trealconstnode(left).value_real:=-trealconstnode(left).value_real;
  275. result:=left;
  276. left:=nil;
  277. exit;
  278. end;
  279. resulttype:=left.resulttype;
  280. if (left.resulttype.def.deftype=floatdef) then
  281. begin
  282. end
  283. {$ifdef SUPPORT_MMX}
  284. else if (cs_mmx in aktlocalswitches) and
  285. is_mmx_able_array(left.resulttype.def) then
  286. begin
  287. { if saturation is on, left.resulttype.def isn't
  288. "mmx able" (FK)
  289. if (cs_mmx_saturation in aktlocalswitches^) and
  290. (torddef(tarraydef(resulttype.def).definition).typ in
  291. [s32bit,u32bit]) then
  292. CGMessage(type_e_mismatch);
  293. }
  294. end
  295. {$endif SUPPORT_MMX}
  296. else if is_64bitint(left.resulttype.def) then
  297. begin
  298. end
  299. else if (left.resulttype.def.deftype=orddef) then
  300. begin
  301. inserttypeconv(left,s32bittype);
  302. resulttype:=left.resulttype;
  303. end
  304. else
  305. begin
  306. if assigned(overloaded_operators[_minus]) then
  307. minusdef:=overloaded_operators[_minus].definition
  308. else
  309. minusdef:=nil;
  310. while assigned(minusdef) do
  311. begin
  312. if is_equal(tparaitem(minusdef.para.first).paratype.def,left.resulttype.def) and
  313. (tparaitem(minusdef.para.first).next=nil) then
  314. begin
  315. t:=ccallnode.create(ccallparanode.create(left,nil),
  316. overloaded_operators[_minus],nil,nil);
  317. left:=nil;
  318. resulttypepass(t);
  319. result:=t;
  320. exit;
  321. end;
  322. minusdef:=minusdef.nextoverloaded;
  323. end;
  324. CGMessage(type_e_mismatch);
  325. end;
  326. end;
  327. function tunaryminusnode.pass_1 : tnode;
  328. begin
  329. result:=nil;
  330. firstpass(left);
  331. if codegenerror then
  332. exit;
  333. registers32:=left.registers32;
  334. registersfpu:=left.registersfpu;
  335. {$ifdef SUPPORT_MMX}
  336. registersmmx:=left.registersmmx;
  337. {$endif SUPPORT_MMX}
  338. if (left.resulttype.def.deftype=floatdef) then
  339. begin
  340. location.loc:=LOC_FPU;
  341. end
  342. {$ifdef SUPPORT_MMX}
  343. else if (cs_mmx in aktlocalswitches) and
  344. is_mmx_able_array(left.resulttype.def) then
  345. begin
  346. if (left.location.loc<>LOC_MMXREGISTER) and
  347. (registersmmx<1) then
  348. registersmmx:=1;
  349. end
  350. {$endif SUPPORT_MMX}
  351. else if is_64bitint(left.resulttype.def) then
  352. begin
  353. if (left.location.loc<>LOC_REGISTER) and
  354. (registers32<2) then
  355. registers32:=2;
  356. location.loc:=LOC_REGISTER;
  357. end
  358. else if (left.resulttype.def.deftype=orddef) then
  359. begin
  360. if (left.location.loc<>LOC_REGISTER) and
  361. (registers32<1) then
  362. registers32:=1;
  363. location.loc:=LOC_REGISTER;
  364. end;
  365. end;
  366. {****************************************************************************
  367. TNOTNODE
  368. ****************************************************************************}
  369. constructor tnotnode.create(expr : tnode);
  370. begin
  371. inherited create(notn,expr);
  372. end;
  373. function tnotnode.det_resulttype : tnode;
  374. var
  375. t : tnode;
  376. notdef : tprocdef;
  377. v : tconstexprint;
  378. begin
  379. result:=nil;
  380. resulttypepass(left);
  381. set_varstate(left,true);
  382. if codegenerror then
  383. exit;
  384. { constant folding }
  385. if (left.nodetype=ordconstn) then
  386. begin
  387. v:=tordconstnode(left).value;
  388. case torddef(left.resulttype.def).typ of
  389. bool8bit,
  390. bool16bit,
  391. bool32bit :
  392. begin
  393. { here we do a boolean(byte(..)) type cast because }
  394. { boolean(<int64>) is buggy in 1.00 }
  395. v:=byte(not(boolean(byte(v))));
  396. end;
  397. uchar,
  398. u8bit :
  399. v:=byte(not byte(v));
  400. s8bit :
  401. v:=shortint(not shortint(v));
  402. uwidechar,
  403. u16bit :
  404. v:=word(not word(v));
  405. s16bit :
  406. v:=smallint(not smallint(v));
  407. u32bit :
  408. v:=cardinal(not cardinal(v));
  409. s32bit :
  410. v:=longint(not longint(v));
  411. u64bit :
  412. v:=int64(not int64(v)); { maybe qword is required }
  413. s64bit :
  414. v:=int64(not int64(v));
  415. else
  416. CGMessage(type_e_mismatch);
  417. end;
  418. t:=cordconstnode.create(v,left.resulttype);
  419. resulttypepass(t);
  420. result:=t;
  421. exit;
  422. end;
  423. resulttype:=left.resulttype;
  424. if is_boolean(resulttype.def) then
  425. begin
  426. end
  427. else
  428. {$ifdef SUPPORT_MMX}
  429. if (cs_mmx in aktlocalswitches) and
  430. is_mmx_able_array(left.resulttype.def) then
  431. begin
  432. end
  433. else
  434. {$endif SUPPORT_MMX}
  435. if is_64bitint(left.resulttype.def) then
  436. begin
  437. end
  438. else if is_integer(left.resulttype.def) then
  439. begin
  440. end
  441. else
  442. begin
  443. if assigned(overloaded_operators[_op_not]) then
  444. notdef:=overloaded_operators[_op_not].definition
  445. else
  446. notdef:=nil;
  447. while assigned(notdef) do
  448. begin
  449. if is_equal(tparaitem(notdef.para.first).paratype.def,left.resulttype.def) and
  450. (tparaitem(notdef.para.first).next=nil) then
  451. begin
  452. t:=ccallnode.create(ccallparanode.create(left,nil),
  453. overloaded_operators[_op_not],nil,nil);
  454. left:=nil;
  455. resulttypepass(t);
  456. result:=t;
  457. exit;
  458. end;
  459. notdef:=notdef.nextoverloaded;
  460. end;
  461. CGMessage(type_e_mismatch);
  462. end;
  463. end;
  464. function tnotnode.pass_1 : tnode;
  465. begin
  466. result:=nil;
  467. firstpass(left);
  468. if codegenerror then
  469. exit;
  470. location.loc:=left.location.loc;
  471. registers32:=left.registers32;
  472. {$ifdef SUPPORT_MMX}
  473. registersmmx:=left.registersmmx;
  474. {$endif SUPPORT_MMX}
  475. if is_boolean(resulttype.def) then
  476. begin
  477. if (location.loc in [LOC_REFERENCE,LOC_MEM,LOC_CREGISTER]) then
  478. begin
  479. location.loc:=LOC_REGISTER;
  480. if (registers32<1) then
  481. registers32:=1;
  482. end;
  483. { before loading it into flags we need to load it into
  484. a register thus 1 register is need PM }
  485. {$ifdef i386}
  486. if left.location.loc<>LOC_JUMP then
  487. location.loc:=LOC_FLAGS;
  488. {$endif def i386}
  489. end
  490. else
  491. {$ifdef SUPPORT_MMX}
  492. if (cs_mmx in aktlocalswitches) and
  493. is_mmx_able_array(left.resulttype.def) then
  494. begin
  495. if (left.location.loc<>LOC_MMXREGISTER) and
  496. (registersmmx<1) then
  497. registersmmx:=1;
  498. end
  499. else
  500. {$endif SUPPORT_MMX}
  501. if is_64bitint(left.resulttype.def) then
  502. begin
  503. if (location.loc in [LOC_REFERENCE,LOC_MEM,LOC_CREGISTER]) then
  504. begin
  505. location.loc:=LOC_REGISTER;
  506. if (registers32<2) then
  507. registers32:=2;
  508. end;
  509. end
  510. else if is_integer(left.resulttype.def) then
  511. begin
  512. if (left.location.loc<>LOC_REGISTER) and
  513. (registers32<1) then
  514. registers32:=1;
  515. location.loc:=LOC_REGISTER;
  516. end
  517. end;
  518. begin
  519. cmoddivnode:=tmoddivnode;
  520. cshlshrnode:=tshlshrnode;
  521. cunaryminusnode:=tunaryminusnode;
  522. cnotnode:=tnotnode;
  523. end.
  524. {
  525. $Log$
  526. Revision 1.20 2001-04-13 01:22:10 peter
  527. * symtable change to classes
  528. * range check generation and errors fixed, make cycle DEBUG=1 works
  529. * memory leaks fixed
  530. Revision 1.19 2001/04/05 21:00:27 peter
  531. * fix constant not evaluation
  532. Revision 1.18 2001/04/04 22:42:40 peter
  533. * move constant folding into det_resulttype
  534. Revision 1.17 2001/04/02 21:20:31 peter
  535. * resulttype rewrite
  536. Revision 1.16 2001/03/20 18:11:03 jonas
  537. * not (cardinal) now has cardinal instead of longint result (bug reported
  538. in mailinglist) ("merged")
  539. Revision 1.15 2001/03/04 10:38:55 jonas
  540. * fixed 'qword mod/div pos_const' to have qword result
  541. Revision 1.14 2001/02/20 21:48:17 peter
  542. * remove nasm hack
  543. Revision 1.13 2001/01/06 18:28:39 peter
  544. * fixed wrong notes about locals
  545. Revision 1.12 2001/01/05 17:36:57 florian
  546. * the info about exception frames is stored now on the stack
  547. instead on the heap
  548. Revision 1.11 2000/12/25 00:07:26 peter
  549. + new tlinkedlist class (merge of old tstringqueue,tcontainer and
  550. tlinkedlist objects)
  551. Revision 1.10 2000/12/16 15:54:01 jonas
  552. * 'resulttype.def of cardinal shl/shr x' is cardinal instead of longint
  553. Revision 1.9 2000/11/29 00:30:34 florian
  554. * unused units removed from uses clause
  555. * some changes for widestrings
  556. Revision 1.8 2000/10/31 22:02:49 peter
  557. * symtable splitted, no real code changes
  558. Revision 1.7 2000/10/01 19:48:24 peter
  559. * lot of compile updates for cg11
  560. Revision 1.6 2000/09/27 21:33:22 florian
  561. * finally nadd.pas compiles
  562. Revision 1.5 2000/09/27 20:25:44 florian
  563. * more stuff fixed
  564. Revision 1.4 2000/09/24 15:06:19 peter
  565. * use defines.inc
  566. Revision 1.3 2000/09/22 22:48:54 florian
  567. * some fixes
  568. Revision 1.2 2000/09/22 22:09:54 florian
  569. * more stuff converted
  570. Revision 1.1 2000/09/20 21:35:12 florian
  571. * initial revision
  572. }