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