ncgrtti.pas 105 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269227022712272227322742275227622772278227922802281228222832284228522862287228822892290229122922293229422952296229722982299230023012302230323042305230623072308230923102311231223132314231523162317231823192320232123222323232423252326232723282329233023312332233323342335233623372338233923402341234223432344234523462347234823492350235123522353235423552356235723582359236023612362236323642365236623672368236923702371237223732374237523762377237823792380238123822383238423852386238723882389239023912392239323942395239623972398239924002401240224032404240524062407240824092410241124122413241424152416241724182419242024212422242324242425242624272428242924302431243224332434243524362437243824392440244124422443244424452446244724482449245024512452245324542455245624572458245924602461246224632464246524662467246824692470247124722473247424752476247724782479248024812482248324842485248624872488248924902491249224932494249524962497249824992500250125022503250425052506250725082509251025112512251325142515251625172518251925202521252225232524252525262527252825292530253125322533253425352536253725382539254025412542254325442545254625472548254925502551255225532554255525562557255825592560256125622563256425652566256725682569257025712572257325742575257625772578257925802581258225832584258525862587258825892590259125922593259425952596259725982599260026012602260326042605260626072608260926102611261226132614261526162617261826192620262126222623262426252626262726282629263026312632263326342635263626372638263926402641264226432644264526462647264826492650265126522653265426552656265726582659266026612662266326642665266626672668266926702671267226732674267526762677267826792680268126822683268426852686268726882689269026912692
  1. {
  2. Copyright (c) 1998-2002 by Florian Klaempfl
  3. Routines for the code generation of RTTI data structures
  4. This program is free software; you can redistribute it and/or modify
  5. it under the terms of the GNU General Public License as published by
  6. the Free Software Foundation; either version 2 of the License, or
  7. (at your option) any later version.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  11. GNU General Public License for more details.
  12. You should have received a copy of the GNU General Public License
  13. along with this program; if not, write to the Free Software
  14. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  15. ****************************************************************************
  16. }
  17. unit ncgrtti;
  18. {$i fpcdefs.inc}
  19. interface
  20. uses
  21. cclasses,constexp,globtype,
  22. aasmbase,aasmcnst,
  23. symbase,symconst,symtype,symdef,symsym,
  24. parabase;
  25. type
  26. { TRTTIWriter }
  27. TRTTIWriter=class
  28. private
  29. { required internal alignment of the rtti data }
  30. reqalign: shortint;
  31. { required packing of all structures except for ttypeinfo and tpropinfo,
  32. which always use packrecords 1 }
  33. defaultpacking: shortint;
  34. { write comments ? }
  35. addcomments : boolean;
  36. procedure fields_write_rtti(st:tsymtable;rt:trttitype);
  37. procedure params_write_rtti(def:tabstractprocdef;rt:trttitype;allow_hidden:boolean);
  38. procedure fields_write_rtti_data(tcb: ttai_typedconstbuilder; def: tabstractrecorddef; rt: trttitype);
  39. procedure methods_write_rtti(st:tsymtable;rt:trttitype;visibilities:tvisibilities;allow_hidden:boolean);
  40. procedure write_rtti_extrasyms(def:Tdef;rt:Trttitype;mainrtti:Tasmsymbol);
  41. procedure published_write_rtti(def : tobjectdef;rt:trttitype);
  42. procedure properties_write_rtti_data(tcb:ttai_typedconstbuilder;propnamelist:TFPHashObjectList;st:tsymtable;extended_rtti:boolean;visibilities:tvisibilities);
  43. procedure write_extended_method_table(tcb:ttai_typedconstbuilder;def:tabstractrecorddef;packrecords:longint);
  44. procedure write_extended_field_table(tcb:ttai_typedconstbuilder;def:tabstractrecorddef;packrecords:longint);
  45. procedure collect_propnamelist(propnamelist:TFPHashObjectList;def:tabstractrecorddef;visibilities:tvisibilities);
  46. { only use a direct reference if the referenced type can *only* reside
  47. in the same unit as the current one }
  48. function ref_rtti(def:tdef;rt:trttitype;indirect:boolean;suffix:tsymstr):tasmsymbol;
  49. procedure write_rtti_name(tcb: ttai_typedconstbuilder; def: tdef);
  50. procedure write_common_rtti_data(tcb:ttai_typedconstbuilder;def:tdef;rt:trttitype);
  51. procedure write_rtti_data(tcb: ttai_typedconstbuilder; def:tdef; rt: trttitype);
  52. procedure write_attribute_data(tcb: ttai_typedconstbuilder;attr_list:trtti_attribute_list);
  53. procedure write_child_rtti_data(def:tdef;rt:trttitype);
  54. procedure write_rtti_reference(tcb: ttai_typedconstbuilder; def: tdef; rt: trttitype);
  55. procedure write_methods(tcb:ttai_typedconstbuilder;st:tsymtable;extended_rtti:boolean;visibilities:tvisibilities);
  56. procedure write_header(tcb: ttai_typedconstbuilder; def: tdef; typekind: byte);
  57. function write_methodkind(tcb:ttai_typedconstbuilder;def:tabstractprocdef):byte;
  58. procedure write_callconv(tcb:ttai_typedconstbuilder;def:tabstractprocdef);
  59. procedure write_paralocs(tcb:ttai_typedconstbuilder;para:pcgpara);
  60. procedure write_param_flag(tcb:ttai_typedconstbuilder;parasym:tparavarsym);
  61. procedure write_param(tcb:ttai_typedconstbuilder;para:tparavarsym);
  62. procedure write_mop_offset_table(tcb:ttai_typedconstbuilder;def:tabstractrecorddef;mop:tmanagementoperator);
  63. procedure maybe_add_comment(tcb:ttai_typedconstbuilder;const comment : string); inline;
  64. public
  65. constructor create;
  66. procedure write_rtti(def:tdef;rt:trttitype);
  67. procedure write_extended_method_table(tcb:ttai_typedconstbuilder;def:tabstractrecorddef); inline;
  68. procedure write_extended_field_table(tcb:ttai_typedconstbuilder;def:tabstractrecorddef); inline;
  69. function get_rtti_label(def:tdef;rt:trttitype;indirect:boolean):tasmsymbol; inline;
  70. function get_rtti_label_ord2str(def:tdef;rt:trttitype;indirect:boolean):tasmsymbol; inline;
  71. function get_rtti_label_str2ord(def:tdef;rt:trttitype;indirect:boolean):tasmsymbol; inline;
  72. end;
  73. { generate RTTI and init tables }
  74. procedure write_persistent_type_info(st:tsymtable;is_global:boolean);
  75. var
  76. RTTIWriter : TRTTIWriter;
  77. implementation
  78. uses
  79. cutils,
  80. globals,verbose,systems,
  81. node,ncal,ncon,
  82. fmodule, procinfo,
  83. symtable,symutil,
  84. aasmtai,aasmdata,
  85. defutil,
  86. paramgr
  87. ;
  88. const
  89. rttidefstate : array[trttitype] of tdefstate =
  90. (ds_rtti_table_written,ds_init_table_written,
  91. { Objective-C related, does not pass here }
  92. symconst.ds_none,symconst.ds_none,
  93. symconst.ds_none,symconst.ds_none);
  94. rttitypenames : array[trttitype] of string =
  95. ('full','init',
  96. 'objcmeta','objcmetaro',
  97. 'objcclass','objcclassro');
  98. type
  99. TPropNameListItem = class(TFPHashObject)
  100. propindex : longint;
  101. propowner : TSymtable;
  102. end;
  103. function visibility_to_rtti_flags(vis: tvisibility): byte;
  104. begin
  105. case vis of
  106. vis_private:
  107. result:=byte(rv_private);
  108. vis_strictprivate:
  109. begin
  110. result:=byte(rv_private);
  111. // add bit to indicate "strict"
  112. result:=result or (1 shl 2);
  113. end;
  114. vis_protected:
  115. result:=byte(rv_protected);
  116. vis_strictprotected:
  117. begin
  118. result:=byte(rv_protected);
  119. // add bit to indicate "strict"
  120. result:=result or (1 shl 2);
  121. end;
  122. vis_public:
  123. result:=byte(rv_public);
  124. vis_published:
  125. result:=byte(rv_published);
  126. otherwise
  127. internalerror(2021061301);
  128. end;
  129. end;
  130. procedure write_persistent_type_info(st: tsymtable; is_global: boolean);
  131. var
  132. i : longint;
  133. def : tdef;
  134. begin
  135. { no Delphi-style RTTI for managed platforms }
  136. if target_info.system in systems_managed_vm then
  137. exit;
  138. for i:=0 to st.DefList.Count-1 do
  139. begin
  140. def:=tdef(st.DefList[i]);
  141. { skip generics }
  142. if [df_generic,df_genconstraint]*def.defoptions<>[] then
  143. continue;
  144. case def.typ of
  145. recorddef:
  146. write_persistent_type_info(trecorddef(def).symtable,is_global);
  147. objectdef :
  148. begin
  149. { Skip forward defs }
  150. if (oo_is_forward in tobjectdef(def).objectoptions) then
  151. continue;
  152. { skip unique type aliases, they use the RTTI from the parent class }
  153. if tobjectdef(def).is_unique_objpasdef then
  154. continue;
  155. write_persistent_type_info(tobjectdef(def).symtable,is_global);
  156. end;
  157. procdef :
  158. begin
  159. if assigned(tprocdef(def).localst) and
  160. (tprocdef(def).localst.symtabletype=localsymtable) then
  161. write_persistent_type_info(tprocdef(def).localst,false);
  162. if assigned(tprocdef(def).parast) then
  163. write_persistent_type_info(tprocdef(def).parast,false);
  164. end;
  165. errordef:
  166. { we shouldn't have come this far if we have an errordef somewhere }
  167. internalerror(2017010701);
  168. undefineddef:
  169. { don't write any RTTI for these }
  170. continue;
  171. else
  172. ;
  173. end;
  174. { always generate persistent tables for types in the interface so
  175. they can be reused in other units and give always the same pointer
  176. location. }
  177. { Init }
  178. if (
  179. assigned(def.typesym) and
  180. is_global and
  181. not is_objc_class_or_protocol(def)
  182. ) or
  183. is_managed_type(def) or
  184. (ds_init_table_used in def.defstates) then
  185. RTTIWriter.write_rtti(def,initrtti);
  186. { RTTI }
  187. if not(df_internal in def.defoptions) and
  188. (
  189. (
  190. assigned(def.typesym) and
  191. is_global and
  192. not is_objc_class_or_protocol(def)
  193. ) or
  194. (ds_rtti_table_used in def.defstates)
  195. ) then
  196. RTTIWriter.write_rtti(def,fullrtti);
  197. end;
  198. end;
  199. {***************************************************************************
  200. TRTTIWriter
  201. ***************************************************************************}
  202. function TRTTIWriter.get_rtti_label(def:tdef;rt:trttitype;indirect:boolean):tasmsymbol;
  203. begin
  204. result:=ref_rtti(def,rt,indirect,'');
  205. end;
  206. function TRTTIWriter.get_rtti_label_ord2str(def:tdef;rt:trttitype;indirect:boolean):tasmsymbol;
  207. begin
  208. result:=ref_rtti(def,rt,indirect,'_o2s');
  209. end;
  210. function TRTTIWriter.get_rtti_label_str2ord(def:tdef;rt:trttitype;indirect:boolean):tasmsymbol;
  211. begin
  212. result:=ref_rtti(def,rt,indirect,'_s2o');
  213. end;
  214. procedure TRTTIWriter.write_methods(tcb:ttai_typedconstbuilder;st:tsymtable;extended_rtti:boolean;visibilities:tvisibilities);
  215. var
  216. rtticount,
  217. totalcount,
  218. i,j,k : longint;
  219. sym : tprocsym;
  220. def : tprocdef;
  221. para : tparavarsym;
  222. begin
  223. maybe_add_comment(tcb,'RTTI: begin methods');
  224. tcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)),
  225. targetinfos[target_info.system]^.alignment.recordalignmin);
  226. totalcount:=0;
  227. rtticount:=0;
  228. for i:=0 to st.symlist.count-1 do
  229. if tsym(st.symlist[i]).typ=procsym then
  230. begin
  231. sym:=tprocsym(st.symlist[i]);
  232. inc(totalcount,sym.procdeflist.count);
  233. for j:=0 to sym.procdeflist.count-1 do
  234. begin
  235. def:=tprocdef(sym.procdeflist[j]);
  236. if (def.visibility in visibilities) and not (def.is_generic) then
  237. inc(rtticount);
  238. end;
  239. end;
  240. { write the count section for non-extended methods }
  241. if not extended_rtti then
  242. begin
  243. maybe_add_comment(tcb,#9'count');
  244. tcb.emit_ord_const(totalcount,u16inttype);
  245. maybe_add_comment(tcb,#9'RTTI count');
  246. if rtticount=0 then
  247. tcb.emit_ord_const($FFFF,u16inttype)
  248. else
  249. tcb.emit_ord_const(rtticount,u16inttype);
  250. end;
  251. if rtticount>0 then
  252. for i:=0 to st.symlist.count-1 do
  253. if tsym(st.symlist[i]).typ=procsym then
  254. begin
  255. sym:=tprocsym(st.symlist[i]);
  256. for j:=0 to sym.procdeflist.count-1 do
  257. begin
  258. def:=tprocdef(sym.procdeflist[j]);
  259. if (def.is_generic) or not (def.visibility in visibilities) then
  260. continue;
  261. def.init_paraloc_info(callerside);
  262. maybe_add_comment(tcb,'RTTI: begin method '+def.fullprocname(false));
  263. tcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)),
  264. targetinfos[target_info.system]^.alignment.recordalignmin);
  265. maybe_add_comment(tcb,#9'return type');
  266. write_rtti_reference(tcb,def.returndef,fullrtti);
  267. maybe_add_comment(tcb,#9'calling convention');
  268. write_callconv(tcb,def);
  269. maybe_add_comment(tcb,#9'method kind');
  270. write_methodkind(tcb,def);
  271. maybe_add_comment(tcb,#9'param count');
  272. tcb.emit_ord_const(def.paras.count,u16inttype);
  273. maybe_add_comment(tcb,#9'caller args size');
  274. tcb.emit_ord_const(def.callerargareasize,sizesinttype);
  275. maybe_add_comment(tcb,#9'invoke helper');
  276. if def.invoke_helper=nil then
  277. tcb.emit_tai(Tai_const.Create_nil_dataptr,voidcodepointertype)
  278. else
  279. tcb.emit_procdef_const(def.invoke_helper);
  280. maybe_add_comment(tcb,#9'name');
  281. tcb.emit_pooled_shortstring_const_ref(sym.realname);
  282. if extended_rtti then
  283. begin
  284. { write visibility section for extended RTTI }
  285. maybe_add_comment(tcb,#9'visibility');
  286. tcb.emit_ord_const(visibility_to_rtti_flags(def.visibility),u8inttype);
  287. { for objects and classes write a VMT index }
  288. if st.defowner.typ=objectdef then
  289. begin
  290. maybe_add_comment(tcb,#9'VMT index');
  291. tcb.emit_ord_const(def.extnumber,u16inttype);
  292. end;
  293. maybe_add_comment(tcb,#9'Code Address');
  294. tcb.emit_procdef_const(def);
  295. maybe_add_comment(tcb,#9'Attribute table');
  296. write_attribute_data(tcb,def.rtti_attribute_list);
  297. end;
  298. for k:=0 to def.paras.count-1 do
  299. write_param(tcb,tparavarsym(def.paras[k]));
  300. if not is_void(def.returndef) then
  301. begin
  302. maybe_add_comment(tcb,#9'return loc');
  303. write_paralocs(tcb,@def.funcretloc[callerside]);
  304. end;
  305. tcb.end_anonymous_record;
  306. maybe_add_comment(tcb,'RTTI: end method '+def.fullprocname(false));
  307. end;
  308. end;
  309. tcb.end_anonymous_record;
  310. maybe_add_comment(tcb,'RTTI: end methods');
  311. end;
  312. procedure TRTTIWriter.write_header(tcb: ttai_typedconstbuilder; def: tdef; typekind: byte);
  313. var
  314. name: shortstring;
  315. begin
  316. if assigned(def.typesym) then
  317. name:=ttypesym(def.typesym).realname
  318. else
  319. name:='';
  320. { TTypeInfo, always packed and doesn't need alignment }
  321. tcb.begin_anonymous_record(
  322. internaltypeprefixName[itp_rtti_header]+tostr(length(name)),1,1,
  323. targetinfos[target_info.system]^.alignment.recordalignmin);
  324. if def.typ=arraydef then
  325. InternalError(201012211);
  326. tcb.emit_tai(Tai_const.Create_8bit(typekind),u8inttype);
  327. tcb.emit_shortstring_const(name);
  328. tcb.end_anonymous_record;
  329. end;
  330. function TRTTIWriter.write_methodkind(tcb:ttai_typedconstbuilder;def:tabstractprocdef):byte;
  331. begin
  332. case def.proctypeoption of
  333. potype_constructor: result:=mkConstructor;
  334. potype_destructor: result:=mkDestructor;
  335. potype_class_constructor: result:=mkClassConstructor;
  336. potype_class_destructor: result:=mkClassDestructor;
  337. potype_operator: result:=mkOperatorOverload;
  338. potype_procedure:
  339. if po_classmethod in def.procoptions then
  340. result:=mkClassProcedure
  341. else
  342. result:=mkProcedure;
  343. potype_function:
  344. if po_classmethod in def.procoptions then
  345. result:=mkClassFunction
  346. else
  347. result:=mkFunction;
  348. else
  349. begin
  350. if def.returndef = voidtype then
  351. result:=mkProcedure
  352. else
  353. result:=mkFunction;
  354. end;
  355. end;
  356. tcb.emit_ord_const(result,u8inttype);
  357. end;
  358. procedure TRTTIWriter.write_callconv(tcb:ttai_typedconstbuilder;def:tabstractprocdef);
  359. const
  360. ProcCallOptionToCallConv: array[tproccalloption] of byte = (
  361. { pocall_none } 0,
  362. { pocall_cdecl } 1,
  363. { pocall_cppdecl } 5,
  364. { pocall_far16 } 6,
  365. { pocall_oldfpccall } 7,
  366. { pocall_internproc } 8,
  367. { pocall_syscall } 9,
  368. { pocall_pascal } 2,
  369. { pocall_register } 0,
  370. { pocall_safecall } 4,
  371. { pocall_stdcall } 3,
  372. { pocall_softfloat } 10,
  373. { pocall_mwpascal } 11,
  374. { pocall_interrupt } 12,
  375. { pocall_hardfloat } 13,
  376. { pocall_sysv_abi_default } 14,
  377. { pocall_sysv_abi_cdecl } 15,
  378. { pocall_ms_abi_default } 16,
  379. { pocall_ms_abi_cdecl } 17,
  380. { pocall_vectorcall } 18
  381. );
  382. begin
  383. tcb.emit_ord_const(ProcCallOptionToCallConv[def.proccalloption],u8inttype);
  384. end;
  385. procedure TRTTIWriter.write_paralocs(tcb:ttai_typedconstbuilder;para:pcgpara);
  386. var
  387. locs : trttiparalocs;
  388. i : longint;
  389. pool : THashSet;
  390. entry : PHashSetItem;
  391. loclab : TAsmLabel;
  392. loctcb : ttai_typedconstbuilder;
  393. datadef : tdef;
  394. begin
  395. locs:=paramanager.cgparalocs_to_rttiparalocs(para^.location);
  396. if length(locs)>high(byte) then
  397. internalerror(2017010601);
  398. if length(locs)=0 then
  399. begin
  400. { *shrugs* }
  401. tcb.emit_tai(Tai_const.Create_nil_codeptr,voidpointertype);
  402. exit;
  403. end;
  404. { do we have such a paraloc already in the pool? }
  405. pool:=current_asmdata.ConstPools[sp_paraloc];
  406. entry:=pool.FindOrAdd(@locs[0],length(locs)*sizeof(trttiparaloc));
  407. if not assigned(entry^.Data) then
  408. begin
  409. current_asmdata.getglobaldatalabel(loclab);
  410. loctcb:=ctai_typedconstbuilder.create([tcalo_is_lab,tcalo_make_dead_strippable]);
  411. loctcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)),
  412. targetinfos[target_info.system]^.alignment.recordalignmin);
  413. loctcb.emit_ord_const(length(locs),u8inttype);
  414. for i:=low(locs) to high(locs) do
  415. begin
  416. loctcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)),
  417. targetinfos[target_info.system]^.alignment.recordalignmin);
  418. loctcb.emit_ord_const(locs[i].loctype,u8inttype);
  419. loctcb.emit_ord_const(locs[i].regsub,u8inttype);
  420. loctcb.emit_ord_const(locs[i].regindex,u16inttype);
  421. { the corresponding type for aint is alusinttype }
  422. loctcb.emit_ord_const(locs[i].offset,alusinttype);
  423. loctcb.end_anonymous_record;
  424. end;
  425. datadef:=loctcb.end_anonymous_record;
  426. current_asmdata.asmlists[al_typedconsts].concatList(
  427. loctcb.get_final_asmlist(loclab,datadef,sec_rodata_norel,loclab.name,const_align(sizeof(pint)))
  428. );
  429. loctcb.free;
  430. entry^.data:=loclab;
  431. end
  432. else
  433. loclab:=TAsmLabel(entry^.Data);
  434. tcb.emit_tai(Tai_const.Create_sym(loclab),voidpointertype);
  435. end;
  436. procedure TRTTIWriter.write_param_flag(tcb:ttai_typedconstbuilder;parasym:tparavarsym);
  437. var
  438. paraspec : word;
  439. begin
  440. case parasym.varspez of
  441. vs_value : paraspec := 0;
  442. vs_const : paraspec := pfConst;
  443. vs_var : paraspec := pfVar;
  444. vs_out : paraspec := pfOut;
  445. vs_constref: paraspec := pfConstRef;
  446. else
  447. internalerror(2013112904);
  448. end;
  449. { Kylix also seems to always add both pfArray and pfReference
  450. in this case
  451. }
  452. if is_open_array(parasym.vardef) or is_array_of_const(parasym.vardef) then
  453. paraspec:=paraspec or pfArray or pfReference;
  454. { and these for classes and interfaces (maybe because they
  455. are themselves addresses?)
  456. }
  457. if is_class_or_interface(parasym.vardef) then
  458. paraspec:=paraspec or pfAddress;
  459. { flags for the hidden parameters }
  460. if vo_is_hidden_para in parasym.varoptions then
  461. paraspec:=paraspec or pfHidden;
  462. if vo_is_high_para in parasym.varoptions then
  463. paraspec:=paraspec or pfHigh;
  464. if vo_is_self in parasym.varoptions then
  465. paraspec:=paraspec or pfSelf;
  466. if vo_is_vmt in parasym.varoptions then
  467. paraspec:=paraspec or pfVmt;
  468. if vo_is_funcret in parasym.varoptions then
  469. paraspec:=paraspec or pfResult;
  470. { set bits run from the highest to the lowest bit on
  471. big endian systems
  472. }
  473. if (target_info.endian = endian_big) then
  474. paraspec:=reverse_word(paraspec);
  475. { write flags for current parameter }
  476. tcb.emit_ord_const(paraspec,u16inttype);
  477. end;
  478. procedure TRTTIWriter.write_param(tcb: ttai_typedconstbuilder;
  479. para: tparavarsym);
  480. begin
  481. maybe_add_comment(tcb,'RTTI: begin param '+para.prettyname);
  482. tcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)),
  483. targetinfos[target_info.system]^.alignment.recordalignmin);
  484. maybe_add_comment(tcb,#9'type');
  485. if is_open_array(para.vardef) or is_array_of_const(para.vardef) then
  486. write_rtti_reference(tcb,tarraydef(para.vardef).elementdef,fullrtti)
  487. else if para.vardef=cformaltype then
  488. write_rtti_reference(tcb,nil,fullrtti)
  489. else
  490. write_rtti_reference(tcb,para.vardef,fullrtti);
  491. maybe_add_comment(tcb,#9'flags');
  492. write_param_flag(tcb,para);
  493. maybe_add_comment(tcb,#9'name');
  494. tcb.emit_pooled_shortstring_const_ref(para.realname);
  495. maybe_add_comment(tcb,#9'locs');
  496. write_paralocs(tcb,@para.paraloc[callerside]);
  497. tcb.end_anonymous_record;
  498. maybe_add_comment(tcb,'RTTI: end param '+para.prettyname);
  499. end;
  500. function compare_mop_offset_entry(item1,item2:pointer):longint;
  501. var
  502. entry1: pmanagementoperator_offset_entry absolute item1;
  503. entry2: pmanagementoperator_offset_entry absolute item2;
  504. begin
  505. if entry1^.offset<entry2^.offset then
  506. result:=-1
  507. else if entry1^.offset>entry2^.offset then
  508. result:=1
  509. else
  510. result:=0;
  511. end;
  512. procedure TRTTIWriter.write_mop_offset_table(tcb:ttai_typedconstbuilder;def:tabstractrecorddef;mop:tmanagementoperator);
  513. var
  514. list : tfplist;
  515. datatcb : ttai_typedconstbuilder;
  516. tbllbl : TAsmLabel;
  517. entry : pmanagementoperator_offset_entry;
  518. datadef,entrydef : tdef;
  519. i : longint;
  520. pdef : tobjectdef;
  521. begin
  522. list:=tfplist.create;
  523. tabstractrecordsymtable(def.symtable).get_managementoperator_offset_list(mop,list);
  524. if (def.typ=objectdef) then
  525. begin
  526. pdef:=tobjectdef(def).childof;
  527. while assigned(pdef) do
  528. begin
  529. tabstractrecordsymtable(pdef.symtable).get_managementoperator_offset_list(mop,list);
  530. pdef:=pdef.childof;
  531. end;
  532. list.sort(@compare_mop_offset_entry);
  533. end;
  534. if list.count=0 then
  535. tcb.emit_tai(tai_const.create_nil_dataptr,voidpointertype)
  536. else
  537. begin
  538. tcb.start_internal_data_builder(current_asmdata.AsmLists[al_rtti],sec_rodata,'',datatcb,tbllbl);
  539. datatcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)),
  540. targetinfos[target_info.system]^.alignment.recordalignmin);
  541. datatcb.emit_ord_const(list.count,u32inttype);
  542. entrydef:=get_recorddef(itp_init_mop_offset_entry,[voidcodepointertype,sizeuinttype],defaultpacking);
  543. for i:=0 to list.count-1 do
  544. begin
  545. entry:=pmanagementoperator_offset_entry(list[i]);
  546. datatcb.maybe_begin_aggregate(entrydef);
  547. datatcb.queue_init(voidcodepointertype);
  548. datatcb.queue_emit_proc(entry^.pd);
  549. datatcb.queue_init(sizeuinttype);
  550. datatcb.queue_emit_ordconst(entry^.offset,sizeuinttype);
  551. datatcb.maybe_end_aggregate(entrydef);
  552. dispose(entry);
  553. end;
  554. datadef:=datatcb.end_anonymous_record;
  555. tcb.finish_internal_data_builder(datatcb,tbllbl,datadef,sizeof(pint));
  556. tcb.emit_tai(tai_const.Create_sym(tbllbl),voidpointertype);
  557. end;
  558. list.free;
  559. end;
  560. procedure TRTTIWriter.write_rtti_name(tcb: ttai_typedconstbuilder; def: tdef);
  561. begin
  562. if is_open_array(def) then
  563. { open arrays never have a typesym with a name, since you cannot
  564. define an "open array type". Kylix prints the type of the
  565. elements in the array in this case (so together with the pfArray
  566. flag, you can reconstruct the full typename, I assume (JM))
  567. }
  568. def:=tarraydef(def).elementdef;
  569. { name }
  570. if assigned(def.typesym) then
  571. tcb.emit_shortstring_const(ttypesym(def.typesym).realname)
  572. else
  573. tcb.emit_shortstring_const('');
  574. end;
  575. procedure TRTTIWriter.write_common_rtti_data(tcb:ttai_typedconstbuilder;def:tdef;rt:trttitype);
  576. begin
  577. if rt<>fullrtti then
  578. write_attribute_data(tcb,nil)
  579. else
  580. write_attribute_data(tcb,tstoreddef(def).rtti_attribute_list);
  581. end;
  582. { writes a 32-bit count followed by array of field infos for given symtable }
  583. procedure TRTTIWriter.fields_write_rtti_data(tcb: ttai_typedconstbuilder; def: tabstractrecorddef; rt: trttitype);
  584. var
  585. i : longint;
  586. sym : tsym;
  587. fieldcnt: longint;
  588. st: tsymtable;
  589. fields: tfplist;
  590. parentrtti: boolean;
  591. begin
  592. fieldcnt:=0;
  593. parentrtti:=false;
  594. st:=def.symtable;
  595. fields:=tfplist.create;
  596. fields.capacity:=st.symlist.count+1;
  597. { For objects, treat parent (if any) as a field with offset 0. This
  598. provides correct handling of entire instance with RTL rtti routines. }
  599. if (def.typ=objectdef) and (tobjectdef(def).objecttype=odt_object) and
  600. Assigned(tobjectdef(def).childof) and
  601. ((rt=fullrtti) or (tobjectdef(def).childof.needs_inittable)) then
  602. begin
  603. parentrtti:=true;
  604. inc(fieldcnt);
  605. end;
  606. for i:=0 to st.SymList.Count-1 do
  607. begin
  608. sym:=tsym(st.SymList[i]);
  609. if is_normal_fieldvarsym(sym) and
  610. (
  611. (rt=fullrtti) or
  612. tfieldvarsym(sym).vardef.needs_inittable
  613. ) and
  614. not is_objc_class_or_protocol(tfieldvarsym(sym).vardef) then
  615. begin
  616. fields.add(tfieldvarsym(sym));
  617. inc(fieldcnt);
  618. end;
  619. end;
  620. { insert field count before data }
  621. maybe_add_comment(tcb,'Field count');
  622. tcb.emit_ord_const(fieldcnt,u32inttype);
  623. { parent object? }
  624. if parentrtti then
  625. begin
  626. write_rtti_reference(tcb,tobjectdef(def).childof,rt);
  627. tcb.emit_ord_const(0,ptruinttype);
  628. end;
  629. { fields }
  630. for i:=0 to fields.count-1 do
  631. begin
  632. sym:=tsym(fields[i]);
  633. maybe_add_comment(tcb,'RTTI begin field '+tostr(i)+': '+sym.prettyname);
  634. write_rtti_reference(tcb,tfieldvarsym(sym).vardef,rt);
  635. tcb.emit_ord_const(tfieldvarsym(sym).fieldoffset,sizeuinttype);
  636. maybe_add_comment(tcb,'RTTI end field '+tostr(i)+': '+sym.prettyname);
  637. end;
  638. fields.free;
  639. end;
  640. procedure TRTTIWriter.fields_write_rtti(st:tsymtable;rt:trttitype);
  641. var
  642. i : longint;
  643. sym : tsym;
  644. begin
  645. for i:=0 to st.SymList.Count-1 do
  646. begin
  647. sym:=tsym(st.SymList[i]);
  648. if is_normal_fieldvarsym(sym) and
  649. (
  650. (rt=fullrtti) or
  651. tfieldvarsym(sym).vardef.needs_inittable
  652. ) then
  653. write_rtti(tfieldvarsym(sym).vardef,rt);
  654. end;
  655. end;
  656. procedure TRTTIWriter.params_write_rtti(def:tabstractprocdef;rt:trttitype;allow_hidden:boolean);
  657. var
  658. i : longint;
  659. sym : tparavarsym;
  660. begin
  661. for i:=0 to def.paras.count-1 do
  662. begin
  663. sym:=tparavarsym(def.paras[i]);
  664. if not (vo_is_hidden_para in sym.varoptions) or allow_hidden then
  665. begin
  666. if is_open_array(sym.vardef) or is_array_of_const(sym.vardef) then
  667. write_rtti(tarraydef(sym.vardef).elementdef,rt)
  668. else
  669. write_rtti(sym.vardef,rt);
  670. end;
  671. end;
  672. end;
  673. procedure TRTTIWriter.methods_write_rtti(st:tsymtable;rt:trttitype;visibilities:tvisibilities;allow_hidden:boolean);
  674. var
  675. i,j : longint;
  676. sym : tprocsym;
  677. def : tabstractprocdef;
  678. begin
  679. for i:=0 to st.symlist.count-1 do
  680. if tsym(st.symlist[i]).typ=procsym then
  681. begin
  682. sym:=tprocsym(st.symlist[i]);
  683. for j:=0 to sym.procdeflist.count-1 do
  684. begin
  685. def:=tabstractprocdef(sym.procdeflist[j]);
  686. write_rtti(def.returndef,rt);
  687. params_write_rtti(def,rt,allow_hidden);
  688. end;
  689. end;
  690. end;
  691. procedure TRTTIWriter.write_extended_method_table(tcb:ttai_typedconstbuilder;def:tabstractrecorddef;packrecords:longint);
  692. var
  693. methodcount,
  694. i, j: longint;
  695. sym: tprocsym;
  696. pdef : tprocdef;
  697. begin
  698. { count methods }
  699. methodcount:=0;
  700. for i:=0 to def.symtable.symlist.count-1 do
  701. if tsym(def.symtable.symlist[i]).typ=procsym then
  702. begin
  703. sym:=tprocsym(def.symtable.symlist[i]);
  704. for j:=0 to sym.procdeflist.count-1 do
  705. begin
  706. pdef:=tprocdef(sym.procdeflist[j]);
  707. if (not pdef.is_generic) and def.is_visible_for_rtti(ro_methods,pdef.visibility) then
  708. inc(methodcount);
  709. end;
  710. end;
  711. tcb.begin_anonymous_record('',packrecords,min(reqalign,SizeOf(PInt)),
  712. targetinfos[target_info.system]^.alignment.recordalignmin);
  713. { emit method count }
  714. maybe_add_comment(tcb,'RTTI Method table: method count');
  715. tcb.emit_ord_const(methodcount,u16inttype);
  716. { emit method entries (array) }
  717. if methodcount>0 then
  718. write_methods(tcb,def.symtable,true,def.rtti_visibilities_for_option(ro_methods));
  719. tcb.end_anonymous_record;
  720. end;
  721. procedure TRTTIWriter.write_extended_method_table(tcb:ttai_typedconstbuilder;def:tabstractrecorddef);
  722. begin
  723. write_extended_method_table(tcb,def,defaultpacking);
  724. end;
  725. procedure TRTTIWriter.write_extended_field_table(tcb:ttai_typedconstbuilder;def:tabstractrecorddef;packrecords:longint);
  726. var
  727. i,cnt: integer;
  728. asym: tsym;
  729. fldsym : tfieldvarsym;
  730. list: TFPList;
  731. begin
  732. list:=TFPList.Create;
  733. { build list of visible fields }
  734. for i:=0 to def.symtable.symlist.Count-1 do
  735. begin
  736. asym:=tsym(def.symtable.symlist[i]);
  737. if (asym.typ=fieldvarsym) and
  738. not(sp_static in asym.symoptions) and
  739. def.is_visible_for_rtti(ro_fields, asym.visibility) then
  740. list.add(asym);
  741. end;
  742. {
  743. TExtendedFieldTable = record
  744. FieldCount: Word;
  745. Fields: array[0..0] of TExtendedFieldInfo;
  746. end;
  747. }
  748. tcb.begin_anonymous_record(internaltypeprefixName[itp_extended_rtti_table]+tostr(list.count),packrecords,min(reqalign,SizeOf(PInt)),targetinfos[target_info.system]^.alignment.recordalignmin);
  749. maybe_add_comment(tcb,'RTTI: Extended Field count');
  750. tcb.emit_ord_const(list.count,u16inttype);
  751. for i := 0 to list.count-1 do
  752. begin
  753. fldsym:=tfieldvarsym(list[i]);
  754. {
  755. TExtendedFieldInfo = record
  756. FieldOffset: SizeUInt;
  757. FieldType: Pointer;
  758. FieldVisibility: Byte;
  759. Name: PShortString;
  760. Attributes :
  761. end;
  762. }
  763. tcb.begin_anonymous_record(internaltypeprefixName[itp_extended_rtti_field]+tostr(fldsym.fieldoffset),packrecords,min(reqalign,SizeOf(PInt)),targetinfos[target_info.system]^.alignment.recordalignmin);
  764. { FieldOffset }
  765. tcb.emit_tai(Tai_const.Create_sizeint(fldsym.fieldoffset),sizeuinttype);
  766. { FieldType: PPTypeInfo }
  767. tcb.emit_tai(Tai_const.Create_sym(RTTIWriter.get_rtti_label(fldsym.vardef,fullrtti,true)),voidpointertype);
  768. { FieldVisibility }
  769. tcb.emit_ord_const(visibility_to_rtti_flags(fldsym.visibility),u8inttype);
  770. { Name }
  771. tcb.emit_pooled_shortstring_const_ref(fldsym.realname);
  772. { Attribute table }
  773. if assigned(fldsym.rtti_attribute_list) and assigned(fldsym.rtti_attribute_list.rtti_attributes) then
  774. cnt:=fldsym.rtti_attribute_list.rtti_attributes.count
  775. else
  776. cnt:=0;
  777. write_attribute_data(tcb,fldsym.rtti_attribute_list);
  778. tcb.end_anonymous_record;
  779. end;
  780. tcb.end_anonymous_record;
  781. list.free;
  782. end;
  783. procedure TRTTIWriter.write_extended_field_table(tcb:ttai_typedconstbuilder;def:tabstractrecorddef);
  784. begin
  785. write_extended_field_table(tcb,def,defaultpacking);
  786. end;
  787. procedure TRTTIWriter.published_write_rtti(def : tobjectdef;rt:trttitype);
  788. var
  789. i : longint;
  790. st : tsymtable;
  791. sym : tsym;
  792. begin
  793. st:=def.symtable;
  794. for i:=0 to st.SymList.Count-1 do
  795. begin
  796. sym:=tsym(st.SymList[i]);
  797. if (sym.visibility=vis_published) or def.is_visible_for_rtti(ro_properties, sym.visibility) then
  798. begin
  799. case tsym(sym).typ of
  800. propertysym:
  801. write_rtti(tpropertysym(sym).propdef,rt);
  802. fieldvarsym:
  803. write_rtti(tfieldvarsym(sym).vardef,rt);
  804. else
  805. ;
  806. end;
  807. end;
  808. end;
  809. end;
  810. procedure TRTTIWriter.collect_propnamelist(propnamelist:TFPHashObjectList;def:tabstractrecorddef;visibilities:tvisibilities);
  811. var
  812. i : longint;
  813. sym : tsym;
  814. pn : tpropnamelistitem;
  815. begin
  816. { search into parent for objects }
  817. if def.typ=objectdef then
  818. begin
  819. if assigned(tobjectdef(def).childof) then
  820. collect_propnamelist(propnamelist,tobjectdef(def).childof,visibilities);
  821. end;
  822. for i:=0 to def.symtable.SymList.Count-1 do
  823. begin
  824. sym:=tsym(def.symtable.SymList[i]);
  825. if (tsym(sym).typ=propertysym) and
  826. (sym.visibility in visibilities) then
  827. begin
  828. pn:=TPropNameListItem(propnamelist.Find(tsym(sym).name));
  829. if not assigned(pn) then
  830. begin
  831. pn:=tpropnamelistitem.create(propnamelist,tsym(sym).name);
  832. pn.propindex:=propnamelist.count-1;
  833. pn.propowner:=tsym(sym).owner;
  834. end;
  835. end;
  836. end;
  837. end;
  838. procedure TRTTIWriter.properties_write_rtti_data(tcb: ttai_typedconstbuilder; propnamelist:TFPHashObjectList; st:tsymtable; extended_rtti:boolean; visibilities:tvisibilities);
  839. var
  840. i : longint;
  841. sym : tsym;
  842. proctypesinfo : byte;
  843. propnameitem : tpropnamelistitem;
  844. propdefname : string;
  845. tbltcb : ttai_typedconstbuilder;
  846. tbllab : tasmlabel;
  847. tbldef : tdef;
  848. visbyte : byte;
  849. procedure writeaccessproc(tcb: ttai_typedconstbuilder; pap:tpropaccesslisttypes; shiftvalue : byte; unsetvalue: byte);
  850. var
  851. typvalue : byte;
  852. hp : ppropaccesslistitem;
  853. extnumber: longint;
  854. address,space : longint;
  855. def : tdef;
  856. hpropsym : tpropertysym;
  857. propaccesslist : tpropaccesslist;
  858. begin
  859. hpropsym:=tpropertysym(sym);
  860. repeat
  861. propaccesslist:=hpropsym.propaccesslist[pap];
  862. if not propaccesslist.empty then
  863. break;
  864. hpropsym:=hpropsym.overriddenpropsym;
  865. until not assigned(hpropsym);
  866. if not(assigned(propaccesslist) and assigned(propaccesslist.firstsym)) then
  867. begin
  868. tcb.emit_tai(Tai_const.Create_int_codeptr(unsetvalue),codeptruinttype);
  869. typvalue:=3;
  870. end
  871. { also for accessing class fields }
  872. else if propaccesslist.firstsym^.sym.typ=fieldvarsym then
  873. begin
  874. address:=0;
  875. hp:=propaccesslist.firstsym;
  876. def:=nil;
  877. while assigned(hp) do
  878. begin
  879. case hp^.sltype of
  880. sl_load :
  881. begin
  882. def:=tfieldvarsym(hp^.sym).vardef;
  883. inc(address,tfieldvarsym(hp^.sym).fieldoffset);
  884. end;
  885. sl_subscript :
  886. begin
  887. if not(assigned(def) and
  888. ((def.typ=recorddef) or
  889. is_object(def))) then
  890. internalerror(200402171);
  891. inc(address,tfieldvarsym(hp^.sym).fieldoffset);
  892. def:=tfieldvarsym(hp^.sym).vardef;
  893. end;
  894. sl_vec :
  895. begin
  896. if not(assigned(def) and (def.typ=arraydef)) then
  897. internalerror(200402172);
  898. def:=tarraydef(def).elementdef;
  899. {Hp.value is a Tconstexprint, which can be rather large,
  900. sanity check for longint overflow.}
  901. space:=(high(address)-address) div def.size;
  902. if int64(space)<hp^.value then
  903. internalerror(200706101);
  904. inc(address,int64(def.size*hp^.value));
  905. end;
  906. else
  907. internalerror(2019050523);
  908. end;
  909. hp:=hp^.next;
  910. end;
  911. tcb.emit_tai(Tai_const.Create_int_codeptr(address),codeptruinttype);
  912. typvalue:=0;
  913. end
  914. else
  915. begin
  916. { When there was an error then procdef is not assigned }
  917. if not assigned(propaccesslist.procdef) then
  918. exit;
  919. if not(po_virtualmethod in tprocdef(propaccesslist.procdef).procoptions) or
  920. is_objectpascal_helper(tprocdef(propaccesslist.procdef).struct) then
  921. begin
  922. tcb.queue_init(codeptruinttype);
  923. tcb.queue_emit_proc(tprocdef(propaccesslist.procdef));
  924. typvalue:=1;
  925. end
  926. else
  927. begin
  928. { virtual method, write vmt offset }
  929. extnumber:=tprocdef(propaccesslist.procdef).extnumber;
  930. tcb.emit_tai(Tai_const.Create_int_codeptr(
  931. tobjectdef(tprocdef(propaccesslist.procdef).struct).vmtmethodoffset(extnumber)),
  932. codeptruinttype);
  933. { register for wpo }
  934. tobjectdef(tprocdef(propaccesslist.procdef).struct).register_vmt_call(extnumber);
  935. {$ifdef vtentry}
  936. { not sure if we can insert those vtentry symbols safely here }
  937. {$error register methods used for published properties}
  938. {$endif vtentry}
  939. typvalue:=2;
  940. end;
  941. end;
  942. proctypesinfo:=proctypesinfo or (typvalue shl shiftvalue);
  943. end;
  944. function properties_count(st:tsymtable):longint;
  945. var
  946. i : longint;
  947. sym : tsym;
  948. begin
  949. result:=0;
  950. for i:=0 to st.SymList.Count-1 do
  951. begin
  952. sym:=tsym(st.SymList[i]);
  953. if (tsym(sym).typ=propertysym) and
  954. (sym.visibility in visibilities) and
  955. (extended_rtti or (tpropertysym(sym).parast=Nil)) and
  956. not (sp_static in sym.symoptions) then
  957. inc(result);
  958. end;
  959. end;
  960. procedure write_prop_params(tcb:ttai_typedconstbuilder;paramst:tsymtable);
  961. var
  962. paramtcb : ttai_typedconstbuilder;
  963. paramlbl : tasmlabel;
  964. paramdef : tdef;
  965. i : longint;
  966. begin
  967. tcb.start_internal_data_builder(current_asmdata.AsmLists[al_rtti],sec_rodata,'',paramtcb,paramlbl);
  968. paramtcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)),
  969. targetinfos[target_info.system]^.alignment.recordalignmin);
  970. { paramcount }
  971. paramtcb.emit_ord_const(paramst.symlist.count,u32inttype);
  972. for i:=0 to paramst.symlist.count-1 do
  973. begin
  974. if tsym(paramst.symlist[i]).typ<>paravarsym then
  975. Internalerror(2024103101);
  976. write_param(paramtcb,tparavarsym(paramst.symlist[i]));
  977. end;
  978. paramdef:=paramtcb.end_anonymous_record;
  979. tcb.finish_internal_data_builder(paramtcb,paramlbl,paramdef,sizeof(pint));
  980. tcb.emit_tai(tai_const.Create_sym(paramlbl),voidpointertype);
  981. end;
  982. function write_propinfo_data(tcb: ttai_typedconstbuilder; sym: tpropertysym): tdef;
  983. begin
  984. { we can only easily reuse defs if the property is not stored,
  985. because otherwise the rtti layout depends on how the "stored"
  986. is defined (field, indexed expression, virtual method, ...) }
  987. if not(ppo_stored in sym.propoptions) then
  988. propdefname:=internaltypeprefixName[itp_rtti_prop]+tostr(length(sym.realname))
  989. else
  990. propdefname:='';
  991. { TPropInfo is a packed record (even on targets that require
  992. alignment), but it starts aligned }
  993. if addcomments then
  994. if assigned(st.name) then
  995. tcb.emit_comment('RTTI: begin propinfo record '+sym.realname+' (class/rec: '+st.name^+')')
  996. else
  997. tcb.emit_comment('RTTI: begin propinfo record '+sym.realname+'(anon)');
  998. tcb.begin_anonymous_record(
  999. propdefname,
  1000. 1,min(reqalign,SizeOf(PInt)),
  1001. targetinfos[target_info.system]^.alignment.recordalignmin);
  1002. if ppo_indexed in sym.propoptions then
  1003. proctypesinfo:=$40
  1004. else
  1005. proctypesinfo:=0;
  1006. if addcomments then
  1007. tcb.emit_comment(#9'type info '+sym.Name+' (Type: '+sym.propdef.GetTypeName+')');
  1008. write_rtti_reference(tcb,sym.propdef,fullrtti);
  1009. if addcomments then
  1010. tcb.emit_comment(#9'read access');
  1011. writeaccessproc(tcb,palt_read,0,0);
  1012. if addcomments then
  1013. tcb.emit_comment(#9'write access');
  1014. writeaccessproc(tcb,palt_write,2,0);
  1015. { is it stored ? }
  1016. if addcomments then
  1017. tcb.emit_comment(#9'stored ?');
  1018. if not(ppo_stored in sym.propoptions) then
  1019. begin
  1020. { no, so put a constant zero }
  1021. tcb.emit_tai(Tai_const.Create_nil_codeptr,codeptruinttype);
  1022. proctypesinfo:=proctypesinfo or (3 shl 4);
  1023. end
  1024. else
  1025. writeaccessproc(tcb,palt_stored,4,1); { maybe; if no procedure put a constant 1 (=true) }
  1026. if addcomments then
  1027. tcb.emit_comment(#9'Index');
  1028. tcb.emit_ord_const(sym.index,u32inttype);
  1029. if addcomments then
  1030. tcb.emit_comment(#9'default');
  1031. tcb.emit_ord_const(sym.default,u32inttype);
  1032. propnameitem:=TPropNameListItem(propnamelist.Find(sym.name));
  1033. if not assigned(propnameitem) then
  1034. internalerror(200512201);
  1035. if addcomments then
  1036. tcb.emit_comment(#9'property index');
  1037. tcb.emit_ord_const(propnameitem.propindex,u16inttype);
  1038. if addcomments then
  1039. tcb.emit_comment(#9'proc types');
  1040. tcb.emit_ord_const(proctypesinfo,u8inttype);
  1041. { index parameters }
  1042. if addcomments then
  1043. tcb.emit_comment(#9'indexed params');
  1044. if extended_rtti and assigned(tpropertysym(sym).parast) then
  1045. write_prop_params(tcb,sym.parast)
  1046. else
  1047. tcb.emit_tai(tai_const.create_nil_dataptr,voidpointertype);
  1048. { write reference to attribute table }
  1049. if addcomments then
  1050. tcb.emit_comment(#9'attributes');
  1051. write_attribute_data(tcb,sym.rtti_attribute_list);
  1052. { write property name }
  1053. if addcomments then
  1054. tcb.emit_comment(#9'name');
  1055. tcb.emit_shortstring_const(sym.realname);
  1056. result:=tcb.end_anonymous_record;
  1057. if addcomments then
  1058. tcb.emit_comment('RTTI: End propinfo record '+sym.realname);
  1059. end;
  1060. begin
  1061. tcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)),
  1062. targetinfos[target_info.system]^.alignment.recordalignmin);
  1063. if extended_rtti then
  1064. maybe_add_comment(tcb,'RTTI: Extended property data: Property count')
  1065. else
  1066. maybe_add_comment(tcb,'RTTI: Legacy property data: Property count');
  1067. tcb.emit_ord_const(properties_count(st),u16inttype);
  1068. for i:=0 to st.SymList.Count-1 do
  1069. begin
  1070. sym:=tsym(st.SymList[i]);
  1071. if (sym.typ=propertysym) and
  1072. (sym.visibility in visibilities) and
  1073. (extended_rtti or (tpropertysym(sym).parast=Nil)) and
  1074. not (sp_static in sym.symoptions) then
  1075. begin
  1076. if extended_rtti then
  1077. begin
  1078. {
  1079. TPropInfoEx = record
  1080. Flags: Byte;
  1081. Info: PPropInfo;
  1082. // AttrData: TAttrData
  1083. end;
  1084. }
  1085. maybe_add_comment(tcb,'RTTI: begin property '+sym.prettyname);
  1086. tcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)),
  1087. targetinfos[target_info.system]^.alignment.recordalignmin);
  1088. { write visiblity flags for extended RTTI }
  1089. maybe_add_comment(tcb,#9'visibility flags');
  1090. visbyte:=byte(visibility_to_rtti_flags(sym.visibility));
  1091. tcb.emit_ord_const(visByte,u8inttype);
  1092. { create separate constant builder }
  1093. current_asmdata.getglobaldatalabel(tbllab);
  1094. tbltcb:=ctai_typedconstbuilder.create([tcalo_is_lab,tcalo_make_dead_strippable]);
  1095. { write TPropInfo record }
  1096. tbldef:=write_propinfo_data(tbltcb,tpropertysym(sym));
  1097. current_asmdata.asmlists[al_rtti].concatlist(
  1098. tbltcb.get_final_asmlist(tbllab,tbldef,sec_rodata,tbllab.name,const_align(sizeof(pint)))
  1099. );
  1100. tbltcb.free;
  1101. { write the pointer to the prop info }
  1102. maybe_add_comment(tcb,#9'property info reference');
  1103. tcb.emit_tai(Tai_const.Create_sym(tbllab),voidpointertype);
  1104. { end record }
  1105. tcb.end_anonymous_record;
  1106. maybe_add_comment(tcb,'RTTI: end property '+sym.prettyname);
  1107. end
  1108. else
  1109. write_propinfo_data(tcb,tpropertysym(sym));
  1110. end;
  1111. end;
  1112. tcb.end_anonymous_record;
  1113. end;
  1114. procedure TRTTIWriter.write_rtti_data(tcb: ttai_typedconstbuilder; def: tdef; rt: trttitype);
  1115. procedure unknown_rtti(def:tstoreddef);
  1116. begin
  1117. tcb.emit_ord_const(tkUnknown,u8inttype);
  1118. write_rtti_name(tcb,def);
  1119. write_common_rtti_data(tcb,def,rt);
  1120. end;
  1121. procedure variantdef_rtti(def:tvariantdef);
  1122. begin
  1123. write_header(tcb,def,tkVariant);
  1124. write_common_rtti_data(tcb,def,rt);
  1125. end;
  1126. procedure stringdef_rtti(def:tstringdef);
  1127. const
  1128. string_typekinds: array[tstringtype] of byte = (
  1129. tkSString,tkLString,tkAString,tkWString,tkUString
  1130. );
  1131. begin
  1132. write_header(tcb,def,string_typekinds[def.stringtype]);
  1133. tcb.begin_anonymous_record(
  1134. internaltypeprefixName[itp_rtti_outer]+tostr(string_typekinds[def.stringtype]),
  1135. defaultpacking,reqalign,
  1136. targetinfos[target_info.system]^.alignment.recordalignmin);
  1137. write_common_rtti_data(tcb,def,rt);
  1138. case def.stringtype of
  1139. st_ansistring:
  1140. begin
  1141. tcb.begin_anonymous_record(
  1142. internaltypeprefixName[itp_rtti_case]+tostr(string_typekinds[def.stringtype]),
  1143. defaultpacking,reqalign,
  1144. targetinfos[target_info.system]^.alignment.recordalignmin);
  1145. tcb.emit_ord_const(def.encoding,u16inttype);
  1146. tcb.end_anonymous_record;
  1147. end;
  1148. st_shortstring:
  1149. begin
  1150. tcb.begin_anonymous_record(
  1151. internaltypeprefixName[itp_rtti_case]+tostr(string_typekinds[def.stringtype]),
  1152. defaultpacking,reqalign,
  1153. targetinfos[target_info.system]^.alignment.recordalignmin);
  1154. tcb.emit_ord_const(def.len,u8inttype);
  1155. tcb.end_anonymous_record;
  1156. end;
  1157. st_widestring,
  1158. st_unicodestring,
  1159. st_longstring:
  1160. { nothing }
  1161. ;
  1162. end;
  1163. tcb.end_anonymous_record;
  1164. end;
  1165. procedure enumdef_rtti(def: tenumdef);
  1166. var
  1167. i : integer;
  1168. hp : tenumsym;
  1169. begin
  1170. write_header(tcb,def,tkEnumeration);
  1171. { align; the named fields are so that we can let the compiler
  1172. calculate the string offsets later on }
  1173. tcb.next_field_name:='size_start_rec';
  1174. { add a typename so that it can be reused when writing the the s2o
  1175. and o2s arrays for llvm (otherwise we have to write out the entire
  1176. type definition every time we access an element from this record) }
  1177. tcb.begin_anonymous_record(internaltypeprefixName[itp_rtti_enum_size_start_rec]+def.unique_id_str,defaultpacking,reqalign,
  1178. targetinfos[target_info.system]^.alignment.recordalignmin);
  1179. write_common_rtti_data(tcb,def,rt);
  1180. tcb.next_field_name:='typ_union_rec';
  1181. tcb.begin_anonymous_record(internaltypeprefixName[itp_rtti_enum_size_start_rec2]+def.unique_id_str,defaultpacking,reqalign,
  1182. targetinfos[target_info.system]^.alignment.recordalignmin);
  1183. case longint(def.size) of
  1184. 1 :
  1185. tcb.emit_ord_const(otUByte,u8inttype);
  1186. 2 :
  1187. tcb.emit_ord_const(otUWord,u8inttype);
  1188. 4 :
  1189. tcb.emit_ord_const(otULong,u8inttype);
  1190. end;
  1191. { we need to align by Tconstptruint here to satisfy the alignment
  1192. rules set by records: in the typinfo unit we overlay a TTypeData
  1193. record on this data, which at the innermost variant record needs an
  1194. alignment of TConstPtrUint due to e.g. the "CompType" member for
  1195. tkSet (also the "BaseType" member for tkEnumeration).
  1196. We need to adhere to this, otherwise things will break. }
  1197. tcb.next_field_name:='min_max_rec';
  1198. tcb.begin_anonymous_record(internaltypeprefixName[itp_rtti_enum_min_max_rec]+def.unique_id_str,defaultpacking,reqalign,
  1199. targetinfos[target_info.system]^.alignment.recordalignmin);
  1200. tcb.emit_ord_const(def.min,s32inttype);
  1201. tcb.emit_ord_const(def.max,s32inttype);
  1202. tcb.next_field_name:='basetype_array_rec';
  1203. { all strings must appear right after each other -> from now on
  1204. packrecords 1 (but the start must still be aligned) }
  1205. tcb.begin_anonymous_record(internaltypeprefixName[itp_rtti_enum_basetype_array_rec]+def.unique_id_str,1,reqalign,
  1206. targetinfos[target_info.system]^.alignment.recordalignmin);
  1207. { write base type }
  1208. write_rtti_reference(tcb,def.basedef,rt);
  1209. for i:=0 to def.symtable.SymList.Count-1 do
  1210. begin
  1211. hp:=tenumsym(def.symtable.SymList[i]);
  1212. if hp.value<def.minval then
  1213. continue
  1214. else
  1215. if hp.value>def.maxval then
  1216. break;
  1217. tcb.next_field_name:=hp.name;
  1218. tcb.emit_shortstring_const(hp.realname);
  1219. end;
  1220. { write unit name }
  1221. tcb.emit_shortstring_const(current_module.realmodulename^);
  1222. { write zero which is required by RTL }
  1223. tcb.emit_ord_const(0,u8inttype);
  1224. { terminate all records }
  1225. tcb.end_anonymous_record;
  1226. tcb.end_anonymous_record;
  1227. tcb.end_anonymous_record;
  1228. tcb.end_anonymous_record;
  1229. end;
  1230. procedure orddef_rtti(def:torddef);
  1231. procedure doint32_64(typekind: byte;min,max:int64);
  1232. const
  1233. trans : array[tordtype] of byte =
  1234. (otUByte{otNone},
  1235. otUByte,otUWord,otULong,otUQWord,otUByte{otNone},
  1236. otSByte,otSWord,otSLong,otSQWord,otUByte{otNone},
  1237. otUByte,otUByte,otUWord,otULong,otUQWord,
  1238. otSByte,otSWord,otSLong,otSQWord,
  1239. otUByte,otUWord,otUByte,255);
  1240. var
  1241. elesize: string[1];
  1242. deftrans: byte;
  1243. begin
  1244. write_header(tcb,def,typekind);
  1245. deftrans:=trans[def.ordtype];
  1246. case deftrans of
  1247. otUQWord,
  1248. otSQWord:
  1249. elesize:='8';
  1250. 255:
  1251. begin
  1252. if def.packedbitsize<=32 then
  1253. begin
  1254. elesize:='4';
  1255. if def.low<0 then
  1256. deftrans:=otSLong
  1257. else
  1258. deftrans:=otULong;
  1259. end
  1260. else
  1261. begin
  1262. elesize:='8';
  1263. if def.low<0 then
  1264. deftrans:=otSQWord
  1265. else
  1266. deftrans:=otUQWord;
  1267. end;
  1268. end
  1269. else
  1270. elesize:='4'
  1271. end;
  1272. tcb.begin_anonymous_record(
  1273. internaltypeprefixName[itp_rtti_ord_outer]+elesize,
  1274. defaultpacking,reqalign,
  1275. targetinfos[target_info.system]^.alignment.recordalignmin);
  1276. write_common_rtti_data(tcb,def,rt);
  1277. tcb.begin_anonymous_record(
  1278. internaltypeprefixName[itp_rtti_ord_middle]+elesize,
  1279. defaultpacking,reqalign,
  1280. targetinfos[target_info.system]^.alignment.recordalignmin);
  1281. tcb.emit_ord_const(byte(trans[def.ordtype]),u8inttype);
  1282. tcb.begin_anonymous_record(
  1283. internaltypeprefixName[itp_rtti_ord_inner]+elesize,
  1284. defaultpacking,reqalign,
  1285. targetinfos[target_info.system]^.alignment.recordalignmin);
  1286. {Convert to longint to smuggle values in high(longint)+1..high(cardinal) into asmlist.}
  1287. case deftrans of
  1288. otUQWord:
  1289. begin
  1290. tcb.emit_ord_const(min,u64inttype);
  1291. tcb.emit_ord_const(max,u64inttype);
  1292. end;
  1293. otSQWord:
  1294. begin
  1295. tcb.emit_ord_const(min,s64inttype);
  1296. tcb.emit_ord_const(max,s64inttype);
  1297. end;
  1298. else
  1299. begin
  1300. tcb.emit_ord_const(longint(min),s32inttype);
  1301. tcb.emit_ord_const(longint(max),s32inttype);
  1302. end;
  1303. end;
  1304. tcb.end_anonymous_record;
  1305. tcb.end_anonymous_record;
  1306. tcb.end_anonymous_record;
  1307. end;
  1308. procedure dointeger(typekind:byte);inline;
  1309. begin
  1310. doint32_64(typekind,int64(def.low.svalue),int64(def.high.svalue));
  1311. end;
  1312. begin
  1313. case def.ordtype of
  1314. s64bit :
  1315. dointeger(tkInt64);
  1316. u64bit :
  1317. dointeger(tkQWord);
  1318. pasbool1,
  1319. pasbool8,
  1320. pasbool16,
  1321. pasbool32,
  1322. pasbool64:
  1323. dointeger(tkBool);
  1324. { use different low/high values to be Delphi compatible }
  1325. bool8bit,
  1326. bool16bit,
  1327. bool32bit:
  1328. doint32_64(tkBool,longint(low(longint)),longint(high(longint)));
  1329. bool64bit:
  1330. doint32_64(tkBool,low(int64),high(int64));
  1331. uchar:
  1332. dointeger(tkChar);
  1333. uwidechar:
  1334. dointeger(tkWChar);
  1335. scurrency:
  1336. begin
  1337. write_header(tcb,def,tkFloat);
  1338. tcb.begin_anonymous_record(
  1339. internaltypeprefixName[itp_1byte],
  1340. defaultpacking,reqalign,
  1341. targetinfos[target_info.system]^.alignment.recordalignmin);
  1342. write_common_rtti_data(tcb,def,rt);
  1343. tcb.emit_ord_const(ftCurr,u8inttype);
  1344. tcb.end_anonymous_record;
  1345. end;
  1346. else
  1347. dointeger(tkInteger);
  1348. end;
  1349. end;
  1350. procedure floatdef_rtti(def:tfloatdef);
  1351. const
  1352. {tfloattype = (s32real,s64real,s80real,sc80real,s64bit,s128bit);}
  1353. translate : array[tfloattype] of byte =
  1354. (ftSingle,ftDouble,ftExtended,ftExtended,ftComp,ftCurr,ftFloat128);
  1355. begin
  1356. write_header(tcb,def,tkFloat);
  1357. tcb.begin_anonymous_record(
  1358. internaltypeprefixName[itp_1byte],
  1359. defaultpacking,reqalign,
  1360. targetinfos[target_info.system]^.alignment.recordalignmin);
  1361. write_common_rtti_data(tcb,def,rt);
  1362. tcb.begin_anonymous_record(
  1363. internaltypeprefixName[itp_rtti_float],
  1364. defaultpacking,reqalign,
  1365. targetinfos[target_info.system]^.alignment.recordalignmin);
  1366. tcb.emit_ord_const(translate[def.floattype],u8inttype);
  1367. tcb.end_anonymous_record;
  1368. tcb.end_anonymous_record;
  1369. end;
  1370. procedure setdef_rtti(def:tsetdef);
  1371. begin
  1372. write_header(tcb,def,tkSet);
  1373. tcb.begin_anonymous_record(
  1374. internaltypeprefixName[itp_rtti_set_outer],
  1375. defaultpacking,reqalign,
  1376. targetinfos[target_info.system]^.alignment.recordalignmin);
  1377. write_common_rtti_data(tcb,def,rt);
  1378. tcb.begin_anonymous_record(
  1379. internaltypeprefixName[itp_rtti_set_middle],
  1380. defaultpacking,reqalign,
  1381. targetinfos[target_info.system]^.alignment.recordalignmin);
  1382. case def.size of
  1383. 1:
  1384. tcb.emit_ord_const(otUByte,u8inttype);
  1385. 2:
  1386. tcb.emit_ord_const(otUWord,u8inttype);
  1387. 4:
  1388. tcb.emit_ord_const(otULong,u8inttype);
  1389. else
  1390. tcb.emit_ord_const(otUByte,u8inttype);
  1391. end;
  1392. tcb.begin_anonymous_record(
  1393. internaltypeprefixName[itp_rtti_set_inner],
  1394. defaultpacking,reqalign,
  1395. targetinfos[target_info.system]^.alignment.recordalignmin);
  1396. tcb.emit_ord_const(def.size,sizesinttype);
  1397. write_rtti_reference(tcb,def.elementdef,rt);
  1398. tcb.end_anonymous_record;
  1399. tcb.end_anonymous_record;
  1400. tcb.end_anonymous_record;
  1401. end;
  1402. procedure arraydef_rtti(def:tarraydef);
  1403. var
  1404. i,dimcount: byte;
  1405. totalcount: asizeuint;
  1406. finaldef: tdef;
  1407. curdef:tarraydef;
  1408. begin
  1409. if ado_IsDynamicArray in def.arrayoptions then
  1410. tcb.emit_ord_const(tkDynArray,u8inttype)
  1411. else
  1412. tcb.emit_ord_const(tkArray,u8inttype);
  1413. write_rtti_name(tcb,def);
  1414. if not(ado_IsDynamicArray in def.arrayoptions) then
  1415. begin
  1416. { remember tha last instruction. we will need to insert some
  1417. calculated values after it }
  1418. finaldef:=def;
  1419. totalcount:=1;
  1420. dimcount:=0;
  1421. repeat
  1422. curdef:=tarraydef(finaldef);
  1423. finaldef:=curdef.elementdef;
  1424. { Dims[i] PTypeInfo }
  1425. inc(dimcount);
  1426. totalcount:=totalcount*curdef.elecount;
  1427. until (finaldef.typ<>arraydef) or
  1428. (ado_IsDynamicArray in tarraydef(finaldef).arrayoptions);
  1429. tcb.begin_anonymous_record(
  1430. internaltypeprefixName[itp_rtti_normal_array]+tostr(dimcount),
  1431. defaultpacking,reqalign,
  1432. targetinfos[target_info.system]^.alignment.recordalignmin);
  1433. write_common_rtti_data(tcb,def,rt);
  1434. tcb.begin_anonymous_record(internaltypeprefixName[itp_rtti_normal_array_inner]+tostr(dimcount),
  1435. defaultpacking,reqalign,
  1436. targetinfos[target_info.system]^.alignment.recordalignmin);
  1437. { total size = elecount * elesize of the first arraydef }
  1438. tcb.emit_tai(Tai_const.Create_sizeint(def.elecount*def.elesize),sizeuinttype);
  1439. { total element count }
  1440. tcb.emit_tai(Tai_const.Create_sizeint(asizeint(totalcount)),sizeuinttype);
  1441. { last dimension element type }
  1442. tcb.emit_tai(Tai_const.Create_sym(get_rtti_label(curdef.elementdef,rt,true)),voidpointertype);
  1443. { dimension count }
  1444. tcb.emit_ord_const(dimcount,u8inttype);
  1445. finaldef:=def;
  1446. { ranges of the dimensions }
  1447. for i:=1 to dimcount do
  1448. begin
  1449. curdef:=tarraydef(finaldef);
  1450. finaldef:=curdef.elementdef;
  1451. { Dims[i] PPTypeInfo }
  1452. write_rtti_reference(tcb,curdef.rangedef,rt);
  1453. end;
  1454. end
  1455. else
  1456. { write a delphi almost compatible dyn. array entry:
  1457. there are two types, eltype and eltype2, the latter is nil if the element type needs
  1458. no finalization, the former is always valid, delphi has this swapped, but for
  1459. compatibility with older fpc versions we do it different, to be delphi compatible,
  1460. the names are swapped in typinfo.pp
  1461. }
  1462. begin
  1463. tcb.begin_anonymous_record(
  1464. internaltypeprefixName[itp_rtti_dyn_array],
  1465. defaultpacking,reqalign,
  1466. targetinfos[target_info.system]^.alignment.recordalignmin);
  1467. write_common_rtti_data(tcb,def,rt);
  1468. { record in TypInfo is aligned differently from init rtti }
  1469. tcb.begin_anonymous_record(
  1470. internaltypeprefixName[itp_rtti_dyn_array_inner],
  1471. defaultpacking,reqalign,
  1472. targetinfos[target_info.system]^.alignment.recordalignmin);
  1473. { size of elements }
  1474. tcb.emit_tai(Tai_const.Create_sizeint(def.elesize),sizeuinttype);
  1475. { element type }
  1476. write_rtti_reference(tcb,def.elementdef,rt);
  1477. { variant type }
  1478. tcb.emit_ord_const(tstoreddef(def.elementdef).getvardef,s32inttype);
  1479. { element type }
  1480. if def.elementdef.needs_inittable then
  1481. write_rtti_reference(tcb,def.elementdef,rt)
  1482. else
  1483. tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype);
  1484. { write unit name }
  1485. tcb.emit_shortstring_const(current_module.realmodulename^);
  1486. end;
  1487. tcb.end_anonymous_record;
  1488. tcb.end_anonymous_record;
  1489. end;
  1490. procedure classrefdef_rtti(def:tclassrefdef);
  1491. begin
  1492. write_header(tcb,def,tkClassRef);
  1493. tcb.begin_anonymous_record(
  1494. internaltypeprefixName[itp_rtti_ref],
  1495. defaultpacking,reqalign,
  1496. targetinfos[target_info.system]^.alignment.recordalignmin);
  1497. write_common_rtti_data(tcb,def,rt);
  1498. tcb.begin_anonymous_record(
  1499. internaltypeprefixName[itp_rtti_classref],
  1500. defaultpacking,reqalign,
  1501. targetinfos[target_info.system]^.alignment.recordalignmin);
  1502. write_rtti_reference(tcb,def.pointeddef,rt);
  1503. tcb.end_anonymous_record;
  1504. tcb.end_anonymous_record;
  1505. end;
  1506. procedure pointerdef_rtti(def:tpointerdef);
  1507. begin
  1508. write_header(tcb,def,tkPointer);
  1509. tcb.begin_anonymous_record(
  1510. internaltypeprefixName[itp_rtti_ref],
  1511. defaultpacking,reqalign,
  1512. targetinfos[target_info.system]^.alignment.recordalignmin);
  1513. write_common_rtti_data(tcb,def,rt);
  1514. tcb.begin_anonymous_record(
  1515. internaltypeprefixName[itp_rtti_pointer],
  1516. defaultpacking,reqalign,
  1517. targetinfos[target_info.system]^.alignment.recordalignmin);
  1518. write_rtti_reference(tcb,def.pointeddef,rt);
  1519. tcb.end_anonymous_record;
  1520. tcb.end_anonymous_record;
  1521. end;
  1522. procedure recorddef_rtti(def:trecorddef);
  1523. procedure write_record_operators(rttilab:tasmlabel);
  1524. var
  1525. rttidef: tdef;
  1526. tcb: ttai_typedconstbuilder;
  1527. mop: tmanagementoperator;
  1528. procdef: tprocdef;
  1529. begin
  1530. tcb:=ctai_typedconstbuilder.create([tcalo_make_dead_strippable]);
  1531. tcb.begin_anonymous_record(
  1532. '',
  1533. defaultpacking,min(reqalign,SizeOf(PInt)),
  1534. targetinfos[target_info.system]^.alignment.recordalignmin
  1535. );
  1536. { use "succ" to omit first enum item "mop_none" }
  1537. for mop := succ(low(tmanagementoperator)) to high(tmanagementoperator) do
  1538. begin
  1539. if not (mop in trecordsymtable(def.symtable).managementoperators) then
  1540. tcb.emit_tai(Tai_const.Create_nil_codeptr,voidcodepointertype)
  1541. else
  1542. begin
  1543. procdef := search_management_operator(mop, def);
  1544. if procdef = nil then
  1545. internalerror(201603021)
  1546. else
  1547. tcb.emit_tai(Tai_const.Createname(procdef.mangledname,AT_FUNCTION,0),
  1548. cprocvardef.getreusableprocaddr(procdef,pc_address_only));
  1549. end;
  1550. end;
  1551. rttidef := tcb.end_anonymous_record;
  1552. current_asmdata.AsmLists[al_rtti].concatList(
  1553. tcb.get_final_asmlist(rttilab,rttidef,sec_rodata,rttilab.name,
  1554. sizeof(PInt)));
  1555. tcb.free;
  1556. end;
  1557. procedure write_extended_property_table;
  1558. var
  1559. propnamelist: TFPHashObjectList;
  1560. visibilities: tvisibilities;
  1561. begin
  1562. propnamelist:=TFPHashObjectList.Create;
  1563. visibilities:=def.rtti_visibilities_for_option(ro_properties);
  1564. collect_propnamelist(propnamelist,def,visibilities);
  1565. properties_write_rtti_data(tcb,propnamelist,def.symtable,true,visibilities);
  1566. propnamelist.free;
  1567. end;
  1568. var
  1569. oplab : tasmlabel;
  1570. begin
  1571. write_header(tcb,def,tkRecord);
  1572. { need extra reqalign record, because otherwise the u32 int will
  1573. only be aligned to 4 even on 64 bit target (while the rtti code
  1574. in typinfo expects alignments to sizeof(pointer)) }
  1575. tcb.begin_anonymous_record('',
  1576. defaultpacking,reqalign,
  1577. targetinfos[target_info.system]^.alignment.recordalignmin);
  1578. write_common_rtti_data(tcb,def,rt);
  1579. tcb.begin_anonymous_record('',
  1580. defaultpacking,reqalign,
  1581. targetinfos[target_info.system]^.alignment.recordalignmin);
  1582. { store special terminator for init table for more optimal rtl operations
  1583. strictly related to RecordRTTI procedure in rtti.inc (directly
  1584. related to RTTIRecordRttiInfoToInitInfo function) }
  1585. if rt=initrtti then
  1586. tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype)
  1587. else
  1588. { we use a direct reference as the init RTTI is always in the same
  1589. unit as the full RTTI }
  1590. tcb.emit_tai(Tai_const.Create_sym(get_rtti_label(def,initrtti,false)),voidpointertype);
  1591. tcb.emit_ord_const(def.size,u32inttype);
  1592. oplab:=nil;
  1593. { store rtti management operators only for init table }
  1594. if rt=initrtti then
  1595. begin
  1596. { for now records don't have the initializer table }
  1597. tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype);
  1598. if (trecordsymtable(def.symtable).managementoperators=[]) then
  1599. tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype)
  1600. else
  1601. begin
  1602. current_asmdata.getlocaldatalabel(oplab);
  1603. tcb.emit_tai(Tai_const.Createname(
  1604. oplab.name,
  1605. AT_DATA_FORCEINDIRECT,0),voidpointertype);
  1606. end;
  1607. end;
  1608. fields_write_rtti_data(tcb,def,rt);
  1609. { write extended rtti }
  1610. if rt=fullrtti then
  1611. begin
  1612. write_extended_field_table(tcb,def,defaultpacking);
  1613. write_extended_method_table(tcb,def,defaultpacking);
  1614. write_extended_property_table;
  1615. end;
  1616. tcb.end_anonymous_record;
  1617. tcb.end_anonymous_record;
  1618. { write pointers to operators if needed }
  1619. if (rt=initrtti) and (trecordsymtable(def.symtable).managementoperators<>[]) then
  1620. write_record_operators(oplab);
  1621. end;
  1622. procedure procvardef_rtti(def:tprocvardef);
  1623. procedure write_para(parasym:tparavarsym);
  1624. begin
  1625. { write flags for current parameter }
  1626. write_param_flag(tcb,parasym);
  1627. { write name of current parameter }
  1628. tcb.emit_shortstring_const(parasym.realname);
  1629. { write name of type of current parameter }
  1630. write_rtti_name(tcb,parasym.vardef);
  1631. end;
  1632. procedure write_procedure_param(parasym:tparavarsym);
  1633. begin
  1634. { every parameter is expected to start aligned }
  1635. tcb.begin_anonymous_record(
  1636. internaltypeprefixName[itp_rtti_proc_param]+tostr(length(parasym.realname)),
  1637. defaultpacking,min(reqalign,SizeOf(PInt)),
  1638. targetinfos[target_info.system]^.alignment.recordalignmin);
  1639. { write flags for current parameter }
  1640. write_param_flag(tcb,parasym);
  1641. { write param type }
  1642. if is_open_array(parasym.vardef) or is_array_of_const(parasym.vardef) then
  1643. write_rtti_reference(tcb,tarraydef(parasym.vardef).elementdef,fullrtti)
  1644. else if parasym.vardef=cformaltype then
  1645. write_rtti_reference(tcb,nil,fullrtti)
  1646. else
  1647. write_rtti_reference(tcb,parasym.vardef,fullrtti);
  1648. { write name of current parameter }
  1649. tcb.emit_shortstring_const(parasym.realname);
  1650. tcb.end_anonymous_record;
  1651. end;
  1652. var
  1653. methodkind : byte;
  1654. i : integer;
  1655. begin
  1656. if po_methodpointer in def.procoptions then
  1657. begin
  1658. { write method id and name }
  1659. write_header(tcb,def,tkMethod);
  1660. tcb.begin_anonymous_record('',defaultpacking,reqalign,
  1661. targetinfos[target_info.system]^.alignment.recordalignmin);
  1662. write_common_rtti_data(tcb,def,rt);
  1663. tcb.begin_anonymous_record('',
  1664. defaultpacking,reqalign,
  1665. targetinfos[target_info.system]^.alignment.recordalignmin);
  1666. { write kind of method }
  1667. methodkind:=write_methodkind(tcb,def);
  1668. { write parameter info. The parameters must be written in reverse order
  1669. if this method uses right to left parameter pushing! }
  1670. tcb.emit_ord_const(def.paras.count,u8inttype);
  1671. for i:=0 to def.paras.count-1 do
  1672. write_para(tparavarsym(def.paras[i]));
  1673. if (methodkind=mkFunction) or (methodkind=mkClassFunction) then
  1674. begin
  1675. { write name of result type }
  1676. write_rtti_name(tcb,def.returndef);
  1677. { enclosing record takes care of alignment }
  1678. { write result typeinfo }
  1679. write_rtti_reference(tcb,def.returndef,fullrtti);
  1680. end;
  1681. { write calling convention }
  1682. write_callconv(tcb,def);
  1683. { enclosing record takes care of alignment }
  1684. { write params typeinfo }
  1685. for i:=0 to def.paras.count-1 do
  1686. begin
  1687. if is_open_array(tparavarsym(def.paras[i]).vardef) or is_array_of_const(tparavarsym(def.paras[i]).vardef) then
  1688. write_rtti_reference(tcb,tarraydef(tparavarsym(def.paras[i]).vardef).elementdef,fullrtti)
  1689. else if tparavarsym(def.paras[i]).vardef=cformaltype then
  1690. write_rtti_reference(tcb,nil,fullrtti)
  1691. else
  1692. write_rtti_reference(tcb,tparavarsym(def.paras[i]).vardef,fullrtti);
  1693. end;
  1694. tcb.end_anonymous_record;
  1695. tcb.end_anonymous_record;
  1696. end
  1697. else
  1698. begin
  1699. write_header(tcb,def,tkProcvar);
  1700. tcb.begin_anonymous_record('',defaultpacking,reqalign,
  1701. targetinfos[target_info.system]^.alignment.recordalignmin);
  1702. write_common_rtti_data(tcb,def,rt);
  1703. tcb.begin_anonymous_record('',
  1704. defaultpacking,reqalign,
  1705. targetinfos[target_info.system]^.alignment.recordalignmin);
  1706. { flags }
  1707. tcb.emit_ord_const(0,u8inttype);
  1708. { write calling convention }
  1709. write_callconv(tcb,def);
  1710. { enclosing record takes care of alignment }
  1711. { write result typeinfo }
  1712. write_rtti_reference(tcb,def.returndef,fullrtti);
  1713. { write parameter count }
  1714. tcb.emit_ord_const(def.paras.count,u8inttype);
  1715. for i:=0 to def.paras.count-1 do
  1716. write_procedure_param(tparavarsym(def.paras[i]));
  1717. tcb.end_anonymous_record;
  1718. tcb.end_anonymous_record;
  1719. end;
  1720. end;
  1721. procedure objectdef_rtti(def: tobjectdef);
  1722. procedure objectdef_rtti_fields(def:tobjectdef);
  1723. begin
  1724. maybe_add_comment(tcb,'RTTI begin fields '+def.objname^);
  1725. tcb.begin_anonymous_record('',defaultpacking,reqalign,
  1726. targetinfos[target_info.system]^.alignment.recordalignmin);
  1727. { - for compatiblity with record RTTI we need to write a terminator-
  1728. Nil pointer for initrtti as well for objects
  1729. - for RTTI consistency for objects we need point from fullrtti
  1730. to initrtti
  1731. - classes are assumed to have the same INIT RTTI as records
  1732. (see TObject.CleanupInstance)
  1733. - neither helper nor class type have fullrtti for fields
  1734. }
  1735. if (rt=initrtti) then
  1736. tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype)
  1737. else
  1738. if (def.objecttype=odt_object) then
  1739. tcb.emit_tai(Tai_const.Create_sym(get_rtti_label(def,initrtti,false)),voidpointertype)
  1740. else
  1741. internalerror(2017011801);
  1742. tcb.emit_ord_const(def.size, u32inttype);
  1743. { pointer to management operators available only for initrtti }
  1744. if (rt=initrtti) then
  1745. begin
  1746. { initializer table only available for classes currently }
  1747. if def.objecttype=odt_class then
  1748. write_mop_offset_table(tcb,def,mop_initialize)
  1749. else
  1750. tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype);
  1751. tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype);
  1752. end;
  1753. { enclosing record takes care of alignment }
  1754. fields_write_rtti_data(tcb,def,rt);
  1755. tcb.end_anonymous_record;
  1756. maybe_add_comment(tcb,'RTTI end fields '+def.objname^);
  1757. end;
  1758. procedure objectdef_rtti_interface_init(def:tobjectdef);
  1759. begin
  1760. tcb.emit_ord_const(def.size, u32inttype);
  1761. end;
  1762. procedure objectdef_extended_rtti_class(def:tobjectdef);
  1763. var
  1764. propnamelist : TFPHashObjectList;
  1765. visibilities : tvisibilities;
  1766. begin
  1767. propnamelist:=TFPHashObjectList.Create;
  1768. visibilities:=def.rtti_visibilities_for_option(ro_properties);
  1769. collect_propnamelist(propnamelist,def,visibilities);
  1770. properties_write_rtti_data(tcb,propnamelist,def.symtable,true,visibilities);
  1771. propnamelist.free;
  1772. end;
  1773. procedure objectdef_rtti_class_full(def:tobjectdef);
  1774. var
  1775. propnamelist : TFPHashObjectList;
  1776. begin
  1777. { Collect unique property names with nameindex }
  1778. propnamelist:=TFPHashObjectList.Create;
  1779. collect_propnamelist(propnamelist,def,[vis_published]);
  1780. tcb.begin_anonymous_record('',defaultpacking,reqalign,
  1781. targetinfos[target_info.system]^.alignment.recordalignmin);
  1782. if not is_objectpascal_helper(def) then
  1783. begin
  1784. maybe_add_comment(tcb,#9'Parent type info');
  1785. if (oo_has_vmt in def.objectoptions) then
  1786. tcb.emit_tai(
  1787. Tai_const.Createname(def.vmt_mangledname,AT_DATA_FORCEINDIRECT,0),
  1788. cpointerdef.getreusable(def.vmt_def))
  1789. else
  1790. tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype);
  1791. end;
  1792. { write parent typeinfo }
  1793. maybe_add_comment(tcb,#9'Parent type info');
  1794. write_rtti_reference(tcb,def.childof,fullrtti);
  1795. { write typeinfo of extended type }
  1796. if is_objectpascal_helper(def) then
  1797. if assigned(def.extendeddef) then
  1798. begin
  1799. maybe_add_comment(tcb,#9'helper for type info');
  1800. write_rtti_reference(tcb,def.extendeddef,fullrtti)
  1801. end
  1802. else
  1803. InternalError(2011033001);
  1804. { total number of unique properties }
  1805. maybe_add_comment(tcb,#9'Number of properties');
  1806. tcb.emit_ord_const(propnamelist.count,u16inttype);
  1807. { write unit name }
  1808. maybe_add_comment(tcb, #9'Unit name');
  1809. tcb.emit_shortstring_const(current_module.realmodulename^);
  1810. { write published properties for this object }
  1811. properties_write_rtti_data(tcb,propnamelist,def.symtable,false,[vis_published]);
  1812. { write extended properties }
  1813. objectdef_extended_rtti_class(def);
  1814. tcb.end_anonymous_record;
  1815. propnamelist.free;
  1816. end;
  1817. procedure objectdef_rtti_interface_full(def:tobjectdef);
  1818. var
  1819. propnamelist : TFPHashObjectList;
  1820. { if changed to a set, make sure it's still a byte large, and
  1821. swap appropriately when cross-compiling
  1822. }
  1823. IntfFlags: byte;
  1824. begin
  1825. { Collect unique property names with nameindex }
  1826. propnamelist:=TFPHashObjectList.Create;
  1827. collect_propnamelist(propnamelist,def,[vis_published]);
  1828. tcb.begin_anonymous_record('',defaultpacking,reqalign,
  1829. targetinfos[target_info.system]^.alignment.recordalignmin);
  1830. { write parent typeinfo }
  1831. write_rtti_reference(tcb,def.childof,fullrtti);
  1832. { interface: write flags, iid and iidstr }
  1833. IntfFlags:=0;
  1834. if assigned(def.iidguid) then
  1835. IntfFlags:=IntfFlags or (1 shl ord(ifHasGuid));
  1836. if (def.objecttype=odt_interfacecorba) and (def.iidstr^<>'') then
  1837. IntfFlags:=IntfFlags or (1 shl ord(ifHasStrGUID));
  1838. if (def.objecttype=odt_dispinterface) then
  1839. IntfFlags:=IntfFlags or (1 shl ord(ifDispInterface));
  1840. if (target_info.endian=endian_big) then
  1841. IntfFlags:=reverse_byte(IntfFlags);
  1842. {
  1843. ifDispatch, }
  1844. tcb.emit_ord_const(IntfFlags,u8inttype);
  1845. { write GUID }
  1846. tcb.emit_guid_const(def.iidguid^);
  1847. { write hidden class reference - if it is nil, write_rtti_reference writes nil }
  1848. write_rtti_reference(tcb,def.hiddenclassdef,fullrtti);
  1849. { write unit name }
  1850. tcb.emit_shortstring_const(current_module.realmodulename^);
  1851. tcb.begin_anonymous_record('',defaultpacking,reqalign,
  1852. targetinfos[target_info.system]^.alignment.recordalignmin);
  1853. { write iidstr }
  1854. if def.objecttype=odt_interfacecorba then
  1855. begin
  1856. { prepareguid always allocates an empty string }
  1857. if not assigned(def.iidstr) then
  1858. internalerror(2016021901);
  1859. tcb.emit_shortstring_const(def.iidstr^)
  1860. end;
  1861. { write published properties for this object }
  1862. properties_write_rtti_data(tcb,propnamelist,def.symtable,false,[vis_published]);
  1863. { write published methods for this interface }
  1864. write_methods(tcb,def.symtable,false,[vis_published]);
  1865. tcb.end_anonymous_record;
  1866. tcb.end_anonymous_record;
  1867. propnamelist.free;
  1868. end;
  1869. begin
  1870. case def.objecttype of
  1871. odt_class:
  1872. tcb.emit_ord_const(tkclass,u8inttype);
  1873. odt_object:
  1874. tcb.emit_ord_const(tkobject,u8inttype);
  1875. odt_dispinterface,
  1876. odt_interfacecom:
  1877. tcb.emit_ord_const(tkInterface,u8inttype);
  1878. odt_interfacecorba:
  1879. tcb.emit_ord_const(tkinterfaceCorba,u8inttype);
  1880. odt_helper:
  1881. tcb.emit_ord_const(tkhelper,u8inttype);
  1882. else
  1883. internalerror(200611034);
  1884. end;
  1885. { generate the name }
  1886. tcb.emit_shortstring_const(def.objrealname^);
  1887. tcb.begin_anonymous_record('',defaultpacking,reqalign,
  1888. targetinfos[target_info.system]^.alignment.recordalignmin);
  1889. write_common_rtti_data(tcb,def,rt);
  1890. case rt of
  1891. initrtti :
  1892. begin
  1893. if def.objecttype in [odt_class,odt_object,odt_helper] then
  1894. objectdef_rtti_fields(def)
  1895. else
  1896. objectdef_rtti_interface_init(def);
  1897. end;
  1898. fullrtti :
  1899. begin
  1900. tcb.begin_anonymous_record('',
  1901. defaultpacking,reqalign,
  1902. targetinfos[target_info.system]^.alignment.recordalignmin);
  1903. case def.objecttype of
  1904. odt_helper,
  1905. odt_class:
  1906. objectdef_rtti_class_full(def);
  1907. odt_object:
  1908. objectdef_rtti_fields(def);
  1909. else
  1910. objectdef_rtti_interface_full(def);
  1911. end;
  1912. tcb.end_anonymous_record;
  1913. end;
  1914. else
  1915. ;
  1916. end;
  1917. tcb.end_anonymous_record;
  1918. end;
  1919. begin
  1920. case def.typ of
  1921. variantdef :
  1922. variantdef_rtti(tvariantdef(def));
  1923. stringdef :
  1924. stringdef_rtti(tstringdef(def));
  1925. enumdef :
  1926. enumdef_rtti(tenumdef(def));
  1927. orddef :
  1928. orddef_rtti(torddef(def));
  1929. floatdef :
  1930. floatdef_rtti(tfloatdef(def));
  1931. setdef :
  1932. setdef_rtti(tsetdef(def));
  1933. procvardef :
  1934. procvardef_rtti(tprocvardef(def));
  1935. arraydef :
  1936. begin
  1937. if ado_IsBitPacked in tarraydef(def).arrayoptions then
  1938. unknown_rtti(tstoreddef(def))
  1939. else
  1940. arraydef_rtti(tarraydef(def));
  1941. end;
  1942. recorddef :
  1943. begin
  1944. if trecorddef(def).is_packed then
  1945. unknown_rtti(tstoreddef(def))
  1946. else
  1947. recorddef_rtti(trecorddef(def));
  1948. end;
  1949. objectdef :
  1950. objectdef_rtti(tobjectdef(def));
  1951. classrefdef :
  1952. classrefdef_rtti(tclassrefdef(def));
  1953. pointerdef :
  1954. pointerdef_rtti(tpointerdef(def));
  1955. else
  1956. unknown_rtti(tstoreddef(def));
  1957. end;
  1958. end;
  1959. procedure TRTTIWriter.write_attribute_data(tcb:ttai_typedconstbuilder;attr_list:trtti_attribute_list);
  1960. procedure write_args(tbltcb:ttai_typedconstbuilder;attr:trtti_attribute);
  1961. var
  1962. argtcb : ttai_typedconstbuilder;
  1963. arglab : tasmlabel;
  1964. argdef : tdef;
  1965. i : sizeint;
  1966. begin
  1967. if length(attr.paras)=0 then
  1968. begin
  1969. tbltcb.emit_tai(tai_const.Create_16bit(0),u16inttype);
  1970. tbltcb.emit_tai(tai_const.Create_nil_dataptr,voidpointertype);
  1971. end
  1972. else
  1973. begin
  1974. current_asmdata.getglobaldatalabel(arglab);
  1975. argtcb:=ctai_typedconstbuilder.create([tcalo_is_lab,tcalo_make_dead_strippable]);
  1976. argtcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)),
  1977. targetinfos[target_info.system]^.alignment.recordalignmin);
  1978. for i:=0 to High(attr.paras) do
  1979. begin
  1980. case attr.paras[i].nodetype of
  1981. niln,
  1982. ordconstn,
  1983. realconstn,
  1984. stringconstn,
  1985. pointerconstn,
  1986. guidconstn:
  1987. tconstnode(attr.paras[i]).emit_data(argtcb);
  1988. setconstn:
  1989. tsetconstnode(attr.paras[i]).emit_data(argtcb);
  1990. else
  1991. internalerror(2019070803);
  1992. end;
  1993. end;
  1994. argdef:=argtcb.end_anonymous_record;
  1995. current_asmdata.asmlists[al_rtti].concatlist(
  1996. argtcb.get_final_asmlist(arglab,argdef,sec_rodata,arglab.name,const_align(sizeof(pint)))
  1997. );
  1998. argtcb.free;
  1999. { write argument size and the reference to the argument entry }
  2000. tbltcb.emit_ord_const(argdef.size,u16inttype);
  2001. tbltcb.emit_tai(Tai_const.Create_sym(arglab),voidpointertype);
  2002. end;
  2003. end;
  2004. var
  2005. count,i: word;
  2006. attr : trtti_attribute;
  2007. tbltcb : ttai_typedconstbuilder;
  2008. tbllab : tasmlabel;
  2009. tbldef : tdef;
  2010. begin
  2011. if assigned(attr_list) then
  2012. count:=attr_list.get_attribute_count
  2013. else
  2014. count:=0;
  2015. if count=0 then
  2016. begin
  2017. { write a Nil reference }
  2018. tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype);
  2019. exit;
  2020. end;
  2021. { first write the attribute list as a separate table }
  2022. current_asmdata.getglobaldatalabel(tbllab);
  2023. tbltcb:=ctai_typedconstbuilder.create([tcalo_is_lab,tcalo_make_dead_strippable]);
  2024. tbltcb.begin_anonymous_record(
  2025. internaltypeprefixName[itp_rtti_attr_list]+tostr(count),
  2026. defaultpacking,min(reqalign,SizeOf(PInt)),
  2027. targetinfos[target_info.system]^.alignment.recordalignmin);
  2028. tbltcb.emit_ord_const(count,u16inttype);
  2029. for i:=0 to count-1 do
  2030. begin
  2031. tbltcb.begin_anonymous_record(internaltypeprefixName[itp_rtti_attr_entry],defaultpacking,min(reqalign,SizeOf(PInt)),
  2032. targetinfos[target_info.system]^.alignment.recordalignmin);
  2033. attr:=trtti_attribute(attr_list.rtti_attributes[i]);
  2034. write_rtti_reference(tbltcb,ttypesym(attr.typesym).typedef,fullrtti);
  2035. tbltcb.emit_procdef_const(tprocdef(tcallnode(attr.constructorcall).procdefinition));
  2036. if not assigned(attr.constructorpd) then
  2037. internalerror(2019071004);
  2038. tbltcb.emit_procdef_const(tprocdef(attr.constructorpd));
  2039. write_args(tbltcb,attr);
  2040. tbltcb.end_anonymous_record;
  2041. end;
  2042. tbldef:=tbltcb.end_anonymous_record;
  2043. current_asmdata.asmlists[al_rtti].concatlist(
  2044. tbltcb.get_final_asmlist(tbllab,tbldef,sec_rodata,tbllab.name,const_align(sizeof(pint)))
  2045. );
  2046. tbltcb.free;
  2047. { write the reference to the attribute table }
  2048. tcb.emit_tai(Tai_const.Create_sym(tbllab),voidpointertype);
  2049. end;
  2050. function enumsym_compare_name(item1, item2: pointer): Integer;
  2051. var
  2052. enum1: tenumsym absolute item1;
  2053. enum2: tenumsym absolute item2;
  2054. begin
  2055. if enum1=enum2 then
  2056. result:=0
  2057. else if enum1.name>enum2.name then
  2058. result:=1
  2059. else
  2060. { there can't be equal names, identifiers are unique }
  2061. result:=-1;
  2062. end;
  2063. function enumsym_compare_value(item1, item2: pointer): Integer;
  2064. var
  2065. enum1: tenumsym absolute item1;
  2066. enum2: tenumsym absolute item2;
  2067. begin
  2068. if enum1.value>enum2.value then
  2069. result:=1
  2070. else if enum1.value<enum2.value then
  2071. result:=-1
  2072. else
  2073. result:=0;
  2074. end;
  2075. procedure TRTTIWriter.write_rtti_extrasyms(def:Tdef;rt:Trttitype;mainrtti:Tasmsymbol);
  2076. type Penumsym = ^Tenumsym;
  2077. { Writes a helper table for accelerated conversion of ordinal enum values to strings.
  2078. If you change something in this method, make sure to adapt the corresponding code
  2079. in sstrings.inc. }
  2080. procedure enumdef_rtti_ord2stringindex(rttidef: trecorddef; const syms: tfplist);
  2081. var rttilab:Tasmsymbol;
  2082. h,i,o,prev_value:longint;
  2083. mode:(lookup,search); {Modify with care, ordinal value of enum is written.}
  2084. r:single; {Must be real type because of integer overflow risk.}
  2085. tcb: ttai_typedconstbuilder;
  2086. sym_count: integer;
  2087. tabledef: tdef;
  2088. begin
  2089. {Decide wether a lookup array is size efficient.}
  2090. mode:=lookup;
  2091. sym_count:=syms.count;
  2092. if sym_count>0 then
  2093. begin
  2094. i:=1;
  2095. r:=0;
  2096. h:=tenumsym(syms[0]).value; {Next expected enum value is min.}
  2097. { set prev_value for the first iteration to a value that is
  2098. different from the first one without risking overflow (it's used
  2099. to detect whether two enum values are the same) }
  2100. if h=0 then
  2101. prev_value:=1
  2102. else
  2103. prev_value:=0;
  2104. while i<sym_count do
  2105. begin
  2106. { if two enum values are the same, we have to create a table }
  2107. if (prev_value=h) then
  2108. begin
  2109. mode:=search;
  2110. break;
  2111. end;
  2112. {Calculate size of hole between values. Avoid integer overflows.}
  2113. r:=r+(single(tenumsym(syms[i]).value)-single(h))-1;
  2114. prev_value:=h;
  2115. h:=tenumsym(syms[i]).value;
  2116. inc(i);
  2117. end;
  2118. if r>sym_count then
  2119. mode:=search; {Don't waste more than 50% space.}
  2120. end;
  2121. { write rtti data; make sure that the alignment matches the corresponding data structure
  2122. in the code that uses it (if alignment is required). }
  2123. tcb:=ctai_typedconstbuilder.create([tcalo_make_dead_strippable,tcalo_data_force_indirect]);
  2124. { use TConstPtrUInt packrecords to ensure good alignment }
  2125. tcb.begin_anonymous_record('',defaultpacking,reqalign,
  2126. targetinfos[target_info.system]^.alignment.recordalignmin);
  2127. { now emit the data: first the mode }
  2128. tcb.emit_tai(Tai_const.create_32bit(longint(mode)),u32inttype);
  2129. { align }
  2130. tcb.begin_anonymous_record('',defaultpacking,min(reqalign,sizeof(PInt)),
  2131. targetinfos[target_info.system]^.alignment.recordalignmin);
  2132. if mode=lookup then
  2133. begin
  2134. o:=tenumsym(syms[0]).value; {Start with min value.}
  2135. for i:=0 to sym_count-1 do
  2136. begin
  2137. while o<tenumsym(syms[i]).value do
  2138. begin
  2139. tcb.emit_tai(Tai_const.create_nil_dataptr,ptruinttype);
  2140. inc(o);
  2141. end;
  2142. inc(o);
  2143. tcb.queue_init(voidpointertype);
  2144. tcb.queue_subscriptn_multiple_by_name(rttidef,
  2145. ['size_start_rec',
  2146. 'typ_union_rec',
  2147. 'min_max_rec',
  2148. 'basetype_array_rec',
  2149. tsym(syms[i]).Name]
  2150. );
  2151. tcb.queue_emit_asmsym(mainrtti,rttidef);
  2152. end;
  2153. end
  2154. else
  2155. begin
  2156. tcb.emit_ord_const(sym_count,u32inttype);
  2157. tcb.begin_anonymous_record('',defaultpacking,min(reqalign,sizeof(PInt)),
  2158. targetinfos[target_info.system]^.alignment.recordalignmin);
  2159. for i:=0 to sym_count-1 do
  2160. begin
  2161. tcb.emit_ord_const(tenumsym(syms[i]).value,s32inttype);
  2162. tcb.queue_init(voidpointertype);
  2163. tcb.queue_subscriptn_multiple_by_name(rttidef,
  2164. ['size_start_rec',
  2165. 'typ_union_rec',
  2166. 'min_max_rec',
  2167. 'basetype_array_rec',
  2168. tsym(syms[i]).Name]
  2169. );
  2170. tcb.queue_emit_asmsym(mainrtti,rttidef);
  2171. end;
  2172. tcb.end_anonymous_record;
  2173. end;
  2174. tcb.end_anonymous_record;
  2175. tabledef:=tcb.end_anonymous_record;
  2176. rttilab:=current_asmdata.DefineAsmSymbol(Tstoreddef(def).rtti_mangledname(rt)+'_o2s',AB_GLOBAL,AT_DATA_NOINDIRECT,tabledef);
  2177. current_asmdata.asmlists[al_rtti].concatlist(tcb.get_final_asmlist(
  2178. rttilab,tabledef,sec_rodata,
  2179. rttilab.name,sizeof(PInt)));
  2180. tcb.free;
  2181. current_module.add_public_asmsym(rttilab);
  2182. end;
  2183. { Writes a helper table for accelerated conversion of string to ordinal enum values.
  2184. If you change something in this method, make sure to adapt the corresponding code
  2185. in sstrings.inc. }
  2186. procedure enumdef_rtti_string2ordindex(rttidef: trecorddef; const syms: tfplist);
  2187. var
  2188. tcb: ttai_typedconstbuilder;
  2189. rttilab: Tasmsymbol;
  2190. i:longint;
  2191. tabledef: tdef;
  2192. begin
  2193. { write rtti data }
  2194. tcb:=ctai_typedconstbuilder.create([tcalo_make_dead_strippable,tcalo_data_force_indirect]);
  2195. { begin of Tstring_to_ord }
  2196. tcb.begin_anonymous_record('',defaultpacking,min(reqalign,sizeof(PInt)),
  2197. targetinfos[target_info.system]^.alignment.recordalignmin);
  2198. tcb.emit_ord_const(syms.count,s32inttype);
  2199. { begin of "data" array in Tstring_to_ord }
  2200. tcb.begin_anonymous_record('',defaultpacking,min(reqalign,sizeof(PInt)),
  2201. targetinfos[target_info.system]^.alignment.recordalignmin);
  2202. for i:=0 to syms.count-1 do
  2203. begin
  2204. tcb.emit_ord_const(tenumsym(syms[i]).value,s32inttype);
  2205. { alignment of pointer value handled by enclosing record already }
  2206. tcb.queue_init(voidpointertype);
  2207. tcb.queue_subscriptn_multiple_by_name(rttidef,
  2208. ['size_start_rec',
  2209. 'typ_union_rec',
  2210. 'min_max_rec',
  2211. 'basetype_array_rec',
  2212. tsym(syms[i]).Name]
  2213. );
  2214. tcb.queue_emit_asmsym(mainrtti,rttidef);
  2215. end;
  2216. tcb.end_anonymous_record;
  2217. tabledef:=tcb.end_anonymous_record;
  2218. rttilab:=current_asmdata.DefineAsmSymbol(Tstoreddef(def).rtti_mangledname(rt)+'_s2o',AB_GLOBAL,AT_DATA_NOINDIRECT,tabledef);
  2219. current_asmdata.asmlists[al_rtti].concatlist(tcb.get_final_asmlist(
  2220. rttilab,tabledef,sec_rodata,
  2221. rttilab.name,sizeof(PInt)));
  2222. tcb.free;
  2223. current_module.add_public_asmsym(rttilab);
  2224. end;
  2225. procedure enumdef_rtti_extrasyms(def:Tenumdef);
  2226. var
  2227. t:Tenumsym;
  2228. syms:tfplist;
  2229. i:longint;
  2230. rttitypesym: ttypesym;
  2231. rttidef: trecorddef;
  2232. s:TIDString;
  2233. begin
  2234. { collect enumsyms belonging to this enum type (could be a subsection
  2235. in case of a subrange type) }
  2236. syms:=tfplist.create;
  2237. for i := 0 to def.symtable.SymList.Count - 1 do
  2238. begin
  2239. t:=tenumsym(def.symtable.SymList[i]);
  2240. if t.value<def.minval then
  2241. continue
  2242. else
  2243. if t.value>def.maxval then
  2244. break;
  2245. syms.add(t);
  2246. end;
  2247. { sort the syms by enum name }
  2248. syms.sort(@enumsym_compare_name);
  2249. s:=internaltypeprefixName[itp_rttidef]+def.rtti_mangledname(fullrtti);
  2250. rttitypesym:=try_search_current_module_type(s);
  2251. if not assigned(rttitypesym) or
  2252. (ttypesym(rttitypesym).typedef.typ<>recorddef) then
  2253. internalerror(2015071402);
  2254. rttidef:=trecorddef(ttypesym(rttitypesym).typedef);
  2255. enumdef_rtti_string2ordindex(rttidef,syms);
  2256. { sort the syms by enum value }
  2257. syms.sort(@enumsym_compare_value);
  2258. enumdef_rtti_ord2stringindex(rttidef,syms);
  2259. syms.free;
  2260. end;
  2261. begin
  2262. case def.typ of
  2263. enumdef:
  2264. if rt=fullrtti then
  2265. begin
  2266. enumdef_rtti_extrasyms(Tenumdef(def));
  2267. end;
  2268. else
  2269. ;
  2270. end;
  2271. end;
  2272. procedure TRTTIWriter.write_child_rtti_data(def:tdef;rt:trttitype);
  2273. begin
  2274. case def.typ of
  2275. enumdef :
  2276. if assigned(tenumdef(def).basedef) then
  2277. write_rtti(tenumdef(def).basedef,rt);
  2278. setdef :
  2279. write_rtti(tsetdef(def).elementdef,rt);
  2280. arraydef :
  2281. begin
  2282. write_rtti(tarraydef(def).rangedef,rt);
  2283. write_rtti(tarraydef(def).elementdef,rt);
  2284. end;
  2285. recorddef :
  2286. begin
  2287. { guarantee initrtti for any record for RTTI purposes
  2288. also for fpc_initialize, fpc_finalize }
  2289. if (rt=fullrtti) then
  2290. begin
  2291. include(def.defstates,ds_init_table_used);
  2292. write_rtti(def, initrtti);
  2293. end;
  2294. fields_write_rtti(trecorddef(def).symtable,rt);
  2295. end;
  2296. objectdef :
  2297. begin
  2298. if assigned(tobjectdef(def).childof) then
  2299. write_rtti(tobjectdef(def).childof,rt);
  2300. if (rt=initrtti) or (tobjectdef(def).objecttype=odt_object) then
  2301. fields_write_rtti(tobjectdef(def).symtable,rt)
  2302. else
  2303. published_write_rtti(tobjectdef(def),rt);
  2304. if (rt=fullrtti) then
  2305. begin
  2306. { guarantee initrtti for any object for RTTI purposes
  2307. also for fpc_initialize, fpc_finalize }
  2308. if (tobjectdef(def).objecttype=odt_object) then
  2309. begin
  2310. include(def.defstates,ds_init_table_used);
  2311. write_rtti(def,initrtti);
  2312. end;
  2313. if (is_interface(def) or is_dispinterface(def))
  2314. and (oo_can_have_published in tobjectdef(def).objectoptions) then
  2315. methods_write_rtti(tobjectdef(def).symtable,rt,[vis_published],true);
  2316. end;
  2317. end;
  2318. classrefdef,
  2319. pointerdef:
  2320. if not is_objc_class_or_protocol(tabstractpointerdef(def).pointeddef) then
  2321. write_rtti(tabstractpointerdef(def).pointeddef,rt);
  2322. procvardef:
  2323. params_write_rtti(tabstractprocdef(def),rt,false);
  2324. else
  2325. ;
  2326. end;
  2327. end;
  2328. procedure TRTTIWriter.write_rtti_reference(tcb: ttai_typedconstbuilder; def: tdef; rt: trttitype);
  2329. begin
  2330. { we don't care about the real type here, because
  2331. a) we don't index into these elements
  2332. b) we may not have the rtti type available at the point that we
  2333. are emitting this data, because of forward definitions etc
  2334. c) if the rtti is emitted in another unit, we won't have the type
  2335. available at all
  2336. For the cases where the type is emitted in the current unit and hence
  2337. the underlying system will detect and complain about symbol def
  2338. mismatches, type conversions will have to be inserted afterwards (like
  2339. in llvm/llvmtype)
  2340. }
  2341. if not assigned(def) or is_void(def) or ((rt<>initrtti) and is_objc_class_or_protocol(def)) then
  2342. tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype)
  2343. else
  2344. tcb.emit_tai(Tai_const.Create_sym(get_rtti_label(def,rt,true)),voidpointertype);
  2345. end;
  2346. function TRTTIWriter.ref_rtti(def:tdef;rt:trttitype;indirect:boolean;suffix:tsymstr):tasmsymbol;
  2347. var
  2348. s : tsymstr;
  2349. begin
  2350. s:=def.rtti_mangledname(rt)+suffix;
  2351. result:=current_asmdata.RefAsmSymbol(s,AT_DATA,indirect);
  2352. if def.owner.moduleid<>current_module.moduleid then
  2353. current_module.add_extern_asmsym(s,AB_EXTERNAL,AT_DATA);
  2354. end;
  2355. procedure TRTTIWriter.write_rtti(def:tdef;rt:trttitype);
  2356. var
  2357. tcb: ttai_typedconstbuilder;
  2358. opts : ttcasmlistoptions;
  2359. rttilab: tasmsymbol;
  2360. rttidef: tdef;
  2361. s: TIDString;
  2362. begin
  2363. { only write rtti of definitions from the current module }
  2364. if not findunitsymtable(def.owner).iscurrentunit then
  2365. exit;
  2366. { check if separate initrtti is actually needed }
  2367. if (rt=initrtti) and (not def.needs_separate_initrtti) then
  2368. rt:=fullrtti;
  2369. { prevent recursion }
  2370. if rttidefstate[rt] in def.defstates then
  2371. exit;
  2372. include(def.defstates,rttidefstate[rt]);
  2373. { write first all dependencies }
  2374. write_child_rtti_data(def,rt);
  2375. { write rtti data }
  2376. tcb:=ctai_typedconstbuilder.create([tcalo_make_dead_strippable,tcalo_data_force_indirect]);
  2377. s:=internaltypeprefixName[itp_rttidef]+tstoreddef(def).rtti_mangledname(rt);
  2378. maybe_add_comment(tcb,'RTTI: begin Type '+def.GetTypeName+' ('+rttitypenames[rt]+')');
  2379. tcb.begin_anonymous_record(
  2380. s,
  2381. defaultpacking,reqalign,
  2382. targetinfos[target_info.system]^.alignment.recordalignmin
  2383. );
  2384. write_rtti_data(tcb,def,rt);
  2385. rttidef:=tcb.end_anonymous_record;
  2386. maybe_add_comment(tcb,'RTTI: end Type '+def.GetTypeName+' ('+rttitypenames[rt]+')');
  2387. rttilab:=current_asmdata.DefineAsmSymbol(tstoreddef(def).rtti_mangledname(rt),AB_GLOBAL,AT_DATA_NOINDIRECT,rttidef);
  2388. current_asmdata.AsmLists[al_rtti].concatList(
  2389. tcb.get_final_asmlist(rttilab,rttidef,sec_rodata,rttilab.name,min(target_info.alignment.maxCrecordalign,SizeOf(QWord))));
  2390. tcb.free;
  2391. current_module.add_public_asmsym(rttilab);
  2392. { write additional data }
  2393. write_rtti_extrasyms(def,rt,rttilab);
  2394. end;
  2395. procedure TRTTIWriter.maybe_add_comment(tcb:ttai_typedconstbuilder;const comment : string);
  2396. begin
  2397. if addcomments then
  2398. tcb.emit_comment(comment);
  2399. end;
  2400. constructor TRTTIWriter.create;
  2401. begin
  2402. addcomments:=cs_asm_rtti_source in current_settings.globalswitches;
  2403. if tf_requires_proper_alignment in target_info.flags then
  2404. begin
  2405. reqalign:=min(sizeof(QWord),target_info.alignment.maxCrecordalign);
  2406. defaultpacking:=C_alignment;
  2407. end
  2408. else
  2409. begin
  2410. reqalign:=1;
  2411. defaultpacking:=1;
  2412. end;
  2413. end;
  2414. end.