symppu.pas 16 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561
  1. {
  2. $Id$
  3. Copyright (c) 1998-2002 by Florian Klaempfl, Pierre Muller
  4. Implementation of the reading of PPU Files for the symtable
  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 symppu;
  19. {$i fpcdefs.inc}
  20. interface
  21. uses
  22. cclasses,
  23. globtype,globals,
  24. cpuinfo,aasmbase,
  25. symbase,symtype,
  26. ppu;
  27. type
  28. tcompilerppufile=class(tppufile)
  29. public
  30. procedure checkerror;
  31. procedure getguid(var g: tguid);
  32. function getexprint:tconstexprint;
  33. function getptruint:TConstPtrUInt;
  34. procedure getposinfo(var p:tfileposinfo);
  35. function getderef : pointer;
  36. function getsymlist:tsymlist;
  37. procedure gettype(var t:ttype);
  38. function getasmsymbol:tasmsymbol;
  39. procedure putguid(const g: tguid);
  40. procedure putexprint(v:tconstexprint);
  41. procedure PutPtrUInt(v:TConstPtrUInt);
  42. procedure putposinfo(const p:tfileposinfo);
  43. procedure putderef(p : tsymtableentry);
  44. procedure putsymlist(p:tsymlist);
  45. procedure puttype(const t:ttype);
  46. procedure putasmsymbol(s:tasmsymbol);
  47. end;
  48. implementation
  49. uses
  50. symconst,
  51. verbose;
  52. {*****************************************************************************
  53. TCompilerPPUFile
  54. *****************************************************************************}
  55. procedure tcompilerppufile.checkerror;
  56. begin
  57. if error then
  58. Message(unit_f_ppu_read_error);
  59. end;
  60. procedure tcompilerppufile.getguid(var g: tguid);
  61. begin
  62. getdata(g,sizeof(g));
  63. end;
  64. function tcompilerppufile.getexprint:tconstexprint;
  65. var
  66. l1,l2 : longint;
  67. begin
  68. if sizeof(tconstexprint)=8 then
  69. begin
  70. l1:=getlongint;
  71. l2:=getlongint;
  72. {$ifopt R+}
  73. {$define Range_check_on}
  74. {$endif opt R+}
  75. {$R- needed here }
  76. {$ifdef Delphi}
  77. result:=int64(l1)+(int64(l2) shl 32);
  78. {$else}
  79. result:=qword(l1)+(int64(l2) shl 32);
  80. {$endif}
  81. {$ifdef Range_check_on}
  82. {$R+}
  83. {$undef Range_check_on}
  84. {$endif Range_check_on}
  85. end
  86. else
  87. result:=getlongint;
  88. end;
  89. function tcompilerppufile.getPtrUInt:TConstPtrUInt;
  90. var
  91. l1,l2 : longint;
  92. begin
  93. if sizeof(tconstexprint)=8 then
  94. begin
  95. l1:=getlongint;
  96. l2:=getlongint;
  97. {$ifopt R+}
  98. {$define Range_check_on}
  99. {$endif opt R+}
  100. {$R- needed here }
  101. {$ifdef Delphi}
  102. result:=int64(l1)+(int64(l2) shl 32);
  103. {$else}
  104. result:=qword(l1)+(int64(l2) shl 32);
  105. {$endif}
  106. {$ifdef Range_check_on}
  107. {$R+}
  108. {$undef Range_check_on}
  109. {$endif Range_check_on}
  110. end
  111. else
  112. result:=getlongint;
  113. end;
  114. procedure tcompilerppufile.getposinfo(var p:tfileposinfo);
  115. var
  116. info : byte;
  117. begin
  118. {
  119. info byte layout in bits:
  120. 0-1 - amount of bytes for fileindex
  121. 2-3 - amount of bytes for line
  122. 4-5 - amount of bytes for column
  123. }
  124. info:=getbyte;
  125. case (info and $03) of
  126. 0 : p.fileindex:=getbyte;
  127. 1 : p.fileindex:=getword;
  128. 2 : p.fileindex:=(getbyte shl 16) or getword;
  129. 3 : p.fileindex:=getlongint;
  130. end;
  131. case ((info shr 2) and $03) of
  132. 0 : p.line:=getbyte;
  133. 1 : p.line:=getword;
  134. 2 : p.line:=(getbyte shl 16) or getword;
  135. 3 : p.line:=getlongint;
  136. end;
  137. case ((info shr 4) and $03) of
  138. 0 : p.column:=getbyte;
  139. 1 : p.column:=getword;
  140. 2 : p.column:=(getbyte shl 16) or getword;
  141. 3 : p.column:=getlongint;
  142. end;
  143. end;
  144. function tcompilerppufile.getderef : pointer;
  145. var
  146. hp,p : tderef;
  147. b : tdereftype;
  148. begin
  149. p:=nil;
  150. repeat
  151. hp:=p;
  152. b:=tdereftype(getbyte);
  153. case b of
  154. derefnil :
  155. break;
  156. derefunit,
  157. derefaktrecordindex,
  158. derefaktlocal,
  159. derefaktstaticindex :
  160. begin
  161. p:=tderef.create(b,getword);
  162. p.next:=hp;
  163. break;
  164. end;
  165. derefindex,
  166. dereflocal,
  167. derefpara,
  168. derefrecord :
  169. begin
  170. p:=tderef.create(b,getword);
  171. p.next:=hp;
  172. end;
  173. end;
  174. until false;
  175. getderef:=p;
  176. end;
  177. function tcompilerppufile.getsymlist:tsymlist;
  178. var
  179. sym : tsym;
  180. slt : tsltype;
  181. idx : longint;
  182. p : tsymlist;
  183. begin
  184. p:=tsymlist.create;
  185. p.def:=tdef(getderef);
  186. repeat
  187. slt:=tsltype(getbyte);
  188. case slt of
  189. sl_none :
  190. break;
  191. sl_call,
  192. sl_load,
  193. sl_subscript :
  194. begin
  195. sym:=tsym(getderef);
  196. p.addsym(slt,sym);
  197. end;
  198. sl_vec :
  199. begin
  200. idx:=getlongint;
  201. p.addconst(slt,idx);
  202. end;
  203. else
  204. internalerror(200110204);
  205. end;
  206. until false;
  207. getsymlist:=tsymlist(p);
  208. end;
  209. procedure tcompilerppufile.gettype(var t:ttype);
  210. begin
  211. t.def:=tdef(getderef);
  212. t.sym:=tsym(getderef);
  213. end;
  214. function tcompilerppufile.getasmsymbol:tasmsymbol;
  215. begin
  216. getasmsymbol:=tasmsymbol(pointer(getlongint));
  217. end;
  218. procedure tcompilerppufile.putposinfo(const p:tfileposinfo);
  219. var
  220. oldcrc : boolean;
  221. info : byte;
  222. begin
  223. { posinfo is not relevant for changes in PPU }
  224. oldcrc:=do_crc;
  225. do_crc:=false;
  226. {
  227. info byte layout in bits:
  228. 0-1 - amount of bytes for fileindex
  229. 2-3 - amount of bytes for line
  230. 4-5 - amount of bytes for column
  231. }
  232. info:=0;
  233. { calculate info byte }
  234. if (p.fileindex>$ff) then
  235. begin
  236. if (p.fileindex<=$ffff) then
  237. info:=info or $1
  238. else
  239. if (p.fileindex<=$ffffff) then
  240. info:=info or $2
  241. else
  242. info:=info or $3;
  243. end;
  244. if (p.line>$ff) then
  245. begin
  246. if (p.line<=$ffff) then
  247. info:=info or $4
  248. else
  249. if (p.line<=$ffffff) then
  250. info:=info or $8
  251. else
  252. info:=info or $c;
  253. end;
  254. if (p.column>$ff) then
  255. begin
  256. if (p.column<=$ffff) then
  257. info:=info or $10
  258. else
  259. if (p.column<=$ffffff) then
  260. info:=info or $20
  261. else
  262. info:=info or $30;
  263. end;
  264. { write data }
  265. putbyte(info);
  266. case (info and $03) of
  267. 0 : putbyte(p.fileindex);
  268. 1 : putword(p.fileindex);
  269. 2 : begin
  270. putbyte(p.fileindex shr 16);
  271. putword(p.fileindex and $ffff);
  272. end;
  273. 3 : putlongint(p.fileindex);
  274. end;
  275. case ((info shr 2) and $03) of
  276. 0 : putbyte(p.line);
  277. 1 : putword(p.line);
  278. 2 : begin
  279. putbyte(p.line shr 16);
  280. putword(p.line and $ffff);
  281. end;
  282. 3 : putlongint(p.line);
  283. end;
  284. case ((info shr 4) and $03) of
  285. 0 : putbyte(p.column);
  286. 1 : putword(p.column);
  287. 2 : begin
  288. putbyte(p.column shr 16);
  289. putword(p.column and $ffff);
  290. end;
  291. 3 : putlongint(p.column);
  292. end;
  293. do_crc:=oldcrc;
  294. end;
  295. procedure tcompilerppufile.putguid(const g: tguid);
  296. begin
  297. putdata(g,sizeof(g));
  298. end;
  299. procedure tcompilerppufile.putexprint(v:tconstexprint);
  300. begin
  301. if sizeof(TConstExprInt)=8 then
  302. begin
  303. putlongint(longint(lo(v)));
  304. putlongint(longint(hi(v)));
  305. end
  306. else if sizeof(TConstExprInt)=4 then
  307. putlongint(longint(v))
  308. else
  309. internalerror(2002082601);
  310. end;
  311. procedure tcompilerppufile.PutPtrUInt(v:TConstPtrUInt);
  312. begin
  313. if sizeof(TConstPtrUInt)=8 then
  314. begin
  315. putlongint(longint(lo(v)));
  316. putlongint(longint(hi(v)));
  317. end
  318. else if sizeof(TConstPtrUInt)=4 then
  319. putlongint(longint(v))
  320. else
  321. internalerror(2002082601);
  322. end;
  323. procedure tcompilerppufile.putderef(p : tsymtableentry);
  324. begin
  325. if p=nil then
  326. putbyte(ord(derefnil))
  327. else
  328. begin
  329. { Static symtable ? }
  330. if p.owner.symtabletype=staticsymtable then
  331. begin
  332. putbyte(ord(derefaktstaticindex));
  333. putword(p.indexnr);
  334. end
  335. { Local record/object symtable ? }
  336. else if (p.owner=aktrecordsymtable) then
  337. begin
  338. putbyte(ord(derefaktrecordindex));
  339. putword(p.indexnr);
  340. end
  341. { Local local/para symtable ? }
  342. else if (p.owner=aktlocalsymtable) then
  343. begin
  344. putbyte(ord(derefaktlocal));
  345. putword(p.indexnr);
  346. end
  347. else
  348. begin
  349. putbyte(ord(derefindex));
  350. putword(p.indexnr);
  351. { Current unit symtable ? }
  352. repeat
  353. if not assigned(p) then
  354. internalerror(556655);
  355. case p.owner.symtabletype of
  356. { when writing the pseudo PPU file
  357. to get CRC values the globalsymtable is not yet
  358. a unitsymtable PM }
  359. globalsymtable :
  360. begin
  361. { check if the unit is available in the uses
  362. clause, else it's an error }
  363. if p.owner.unitid=$ffff then
  364. internalerror(55665566);
  365. putbyte(ord(derefunit));
  366. putword(p.owner.unitid);
  367. break;
  368. end;
  369. staticsymtable :
  370. begin
  371. putbyte(ord(derefaktstaticindex));
  372. putword(p.indexnr);
  373. break;
  374. end;
  375. localsymtable :
  376. begin
  377. p:=p.owner.defowner;
  378. putbyte(ord(dereflocal));
  379. putword(p.indexnr);
  380. end;
  381. parasymtable :
  382. begin
  383. p:=p.owner.defowner;
  384. putbyte(ord(derefpara));
  385. putword(p.indexnr);
  386. end;
  387. objectsymtable,
  388. recordsymtable :
  389. begin
  390. p:=p.owner.defowner;
  391. putbyte(ord(derefrecord));
  392. putword(p.indexnr);
  393. end;
  394. else
  395. internalerror(556656);
  396. end;
  397. until false;
  398. end;
  399. end;
  400. end;
  401. procedure tcompilerppufile.putsymlist(p:tsymlist);
  402. var
  403. hp : psymlistitem;
  404. begin
  405. putderef(p.def);
  406. hp:=p.firstsym;
  407. while assigned(hp) do
  408. begin
  409. putbyte(byte(hp^.sltype));
  410. case hp^.sltype of
  411. sl_call,
  412. sl_load,
  413. sl_subscript :
  414. putderef(hp^.sym);
  415. sl_vec :
  416. putlongint(hp^.value);
  417. else
  418. internalerror(200110205);
  419. end;
  420. hp:=hp^.next;
  421. end;
  422. putbyte(byte(sl_none));
  423. end;
  424. procedure tcompilerppufile.puttype(const t:ttype);
  425. begin
  426. { Don't write symbol references for the current unit
  427. and for the system unit }
  428. if assigned(t.sym) and
  429. (t.sym.owner.unitid<>0) and
  430. (t.sym.owner.unitid<>1) then
  431. begin
  432. putderef(nil);
  433. putderef(t.sym);
  434. end
  435. else
  436. begin
  437. putderef(t.def);
  438. putderef(nil);
  439. end;
  440. end;
  441. procedure tcompilerppufile.putasmsymbol(s:tasmsymbol);
  442. begin
  443. if assigned(s) then
  444. begin
  445. if s.ppuidx=-1 then
  446. begin
  447. inc(objectlibrary.asmsymbolppuidx);
  448. s.ppuidx:=objectlibrary.asmsymbolppuidx;
  449. end;
  450. putlongint(s.ppuidx);
  451. end
  452. else
  453. putlongint(0);
  454. end;
  455. end.
  456. {
  457. $Log$
  458. Revision 1.17 2002-10-05 12:43:29 carl
  459. * fixes for Delphi 6 compilation
  460. (warning : Some features do not work under Delphi)
  461. Revision 1.16 2002/08/26 14:05:57 pierre
  462. * fixed compilation cycle with -Cr option by adding explicit
  463. longint typecast in PutPtrUInt and putexprint methods.
  464. + added checks for sizeof and internalerros if size is not handled.
  465. Revision 1.15 2002/08/18 20:06:26 peter
  466. * inlining is now also allowed in interface
  467. * renamed write/load to ppuwrite/ppuload
  468. * tnode storing in ppu
  469. * nld,ncon,nbas are already updated for storing in ppu
  470. Revision 1.14 2002/08/11 14:32:28 peter
  471. * renamed current_library to objectlibrary
  472. Revision 1.13 2002/08/11 13:24:14 peter
  473. * saving of asmsymbols in ppu supported
  474. * asmsymbollist global is removed and moved into a new class
  475. tasmlibrarydata that will hold the info of a .a file which
  476. corresponds with a single module. Added librarydata to tmodule
  477. to keep the library info stored for the module. In the future the
  478. objectfiles will also be stored to the tasmlibrarydata class
  479. * all getlabel/newasmsymbol and friends are moved to the new class
  480. Revision 1.12 2002/05/18 13:34:18 peter
  481. * readded missing revisions
  482. Revision 1.11 2002/05/16 19:46:45 carl
  483. + defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
  484. + try to fix temp allocation (still in ifdef)
  485. + generic constructor calls
  486. + start of tassembler / tmodulebase class cleanup
  487. Revision 1.9 2002/05/12 16:53:15 peter
  488. * moved entry and exitcode to ncgutil and cgobj
  489. * foreach gets extra argument for passing local data to the
  490. iterator function
  491. * -CR checks also class typecasts at runtime by changing them
  492. into as
  493. * fixed compiler to cycle with the -CR option
  494. * fixed stabs with elf writer, finally the global variables can
  495. be watched
  496. * removed a lot of routines from cga unit and replaced them by
  497. calls to cgobj
  498. * u32bit-s32bit updates for and,or,xor nodes. When one element is
  499. u32bit then the other is typecasted also to u32bit without giving
  500. a rangecheck warning/error.
  501. * fixed pascal calling method with reversing also the high tree in
  502. the parast, detected by tcalcst3 test
  503. Revision 1.8 2002/04/19 15:40:40 peter
  504. * optimize tfileposinfo writing, this reduces the ppu size with 20%
  505. }