From edf32cd5dc8e56370af3c599634d46a7611e73b5 Mon Sep 17 00:00:00 2001 From: marco Date: Wed, 26 Sep 2018 12:50:46 +0000 Subject: [PATCH] The Important Ones: - 39683, 39684, 39685, 39686 (rework of Interface Method RTTI) - 39687, 39688, 39689, 39690, 39709, 39710 (change of PPU version) git-svn-id: branches/fixes_3_2@39809 - --- compiler/aasmcnst.pas | 53 +++++++++ compiler/aasmdata.pas | 3 +- compiler/ncgrtti.pas | 169 +++++++++++++++++++++++------ compiler/ncgvmt.pas | 76 +------------ compiler/ppu.pas | 2 +- compiler/symconst.pas | 2 + compiler/symdef.pas | 82 ++++++++++++++ compiler/symtable.pas | 105 +++++++++++++++++- compiler/utils/ppuutils/ppudump.pp | 10 +- rtl/inc/objpas.inc | 32 +++--- rtl/inc/rtti.inc | 4 +- rtl/inc/rttidecl.inc | 38 +++---- rtl/objpas/typinfo.pp | 95 ++++++++-------- 13 files changed, 470 insertions(+), 201 deletions(-) diff --git a/compiler/aasmcnst.pas b/compiler/aasmcnst.pas index 945742fd99..4876a1c972 100644 --- a/compiler/aasmcnst.pas +++ b/compiler/aasmcnst.pas @@ -365,6 +365,9 @@ type { emit an ordinal constant } procedure emit_ord_const(value: int64; def: tdef); + { emit a reference to a pooled shortstring constant } + procedure emit_pooled_shortstring_const_ref(const str:shortstring); + { begin a potential aggregate type. Must be called for any type that consists of multiple tai constant data entries, or that represents an aggregate at the Pascal level (a record, a non-dynamic @@ -1846,6 +1849,56 @@ implementation end; + procedure ttai_typedconstbuilder.emit_pooled_shortstring_const_ref(const str:shortstring); + var + pool : thashset; + entry : phashsetitem; + strlab : tasmlabel; + l : longint; + pc : pansichar; + datadef : tdef; + strtcb : ttai_typedconstbuilder; + begin + pool:=current_asmdata.ConstPools[sp_shortstr]; + + entry:=pool.FindOrAdd(@str[1],length(str)); + + { :-(, we must generate a new entry } + if not assigned(entry^.Data) then + begin + current_asmdata.getglobaldatalabel(strlab); + + { include length and terminating zero for quick conversion to pchar } + l:=length(str); + getmem(pc,l+2); + move(str[1],pc[1],l); + pc[0]:=chr(l); + pc[l+1]:=#0; + + datadef:=carraydef.getreusable(cansichartype,l+2); + + { we start a new constbuilder as we don't know whether we're called + from inside an internal constbuilder } + strtcb:=ctai_typedconstbuilder.create([tcalo_is_lab,tcalo_make_dead_strippable,tcalo_apply_constalign]); + + strtcb.maybe_begin_aggregate(datadef); + strtcb.emit_tai(Tai_string.Create_pchar(pc,l+2),datadef); + strtcb.maybe_end_aggregate(datadef); + + current_asmdata.asmlists[al_typedconsts].concatList( + strtcb.get_final_asmlist(strlab,datadef,sec_rodata_norel,strlab.name,const_align(sizeof(pint))) + ); + strtcb.free; + + entry^.Data:=strlab; + end + else + strlab:=tasmlabel(entry^.Data); + + emit_tai(tai_const.Create_sym(strlab),charpointertype); + end; + + procedure ttai_typedconstbuilder.maybe_begin_aggregate(def: tdef); begin begin_aggregate_internal(def,false); diff --git a/compiler/aasmdata.pas b/compiler/aasmdata.pas index 55f1b2fda3..e0eac8a7ef 100644 --- a/compiler/aasmdata.pas +++ b/compiler/aasmdata.pas @@ -96,7 +96,8 @@ interface sp_objcprotocolrefs, sp_varsets, sp_floats, - sp_guids + sp_guids, + sp_paraloc ); const diff --git a/compiler/ncgrtti.pas b/compiler/ncgrtti.pas index 9d04bb6d1d..6ed1ce0892 100644 --- a/compiler/ncgrtti.pas +++ b/compiler/ncgrtti.pas @@ -65,7 +65,7 @@ interface procedure write_callconv(tcb:ttai_typedconstbuilder;def:tabstractprocdef); procedure write_paralocs(tcb:ttai_typedconstbuilder;para:pcgpara); procedure write_param_flag(tcb:ttai_typedconstbuilder;parasym:tparavarsym); - procedure write_record_init_flag(tcb:ttai_typedconstbuilder;value:longword); + procedure write_mop_offset_table(tcb:ttai_typedconstbuilder;def:tabstractrecorddef;mop:tmanagementoperator); public constructor create; procedure write_rtti(def:tdef;rt:trttitype); @@ -175,7 +175,6 @@ implementation TRTTIWriter ***************************************************************************} - procedure TRTTIWriter.write_methods(tcb:ttai_typedconstbuilder;st:tsymtable;visibilities:tvisibilities); var rtticount, @@ -230,7 +229,7 @@ implementation write_methodkind(tcb,def); tcb.emit_ord_const(def.paras.count,u16inttype); tcb.emit_ord_const(def.callerargareasize,ptrsinttype); - tcb.emit_shortstring_const(sym.realname); + tcb.emit_pooled_shortstring_const_ref(sym.realname); for k:=0 to def.paras.count-1 do begin @@ -245,7 +244,8 @@ implementation else write_rtti_reference(tcb,para.vardef,fullrtti); write_param_flag(tcb,para); - tcb.emit_shortstring_const(para.realname); + + tcb.emit_pooled_shortstring_const_ref(para.realname); write_paralocs(tcb,@para.paraloc[callerside]); @@ -348,27 +348,64 @@ implementation var locs : trttiparalocs; i : longint; + pool : THashSet; + entry : PHashSetItem; + loclab : TAsmLabel; + loctcb : ttai_typedconstbuilder; + datadef : tdef; begin locs:=paramanager.cgparalocs_to_rttiparalocs(para^.location); if length(locs)>high(byte) then internalerror(2017010601); - tcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)), - targetinfos[target_info.system]^.alignment.recordalignmin, - targetinfos[target_info.system]^.alignment.maxCrecordalign); - tcb.emit_ord_const(length(locs),u8inttype); - for i:=low(locs) to high(locs) do + + if length(locs)=0 then begin - tcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)), + { *shrugs* } + tcb.emit_tai(Tai_const.Create_nil_codeptr,voidpointertype); + exit; + end; + + { do we have such a paraloc already in the pool? } + pool:=current_asmdata.ConstPools[sp_paraloc]; + + entry:=pool.FindOrAdd(@locs[0],length(locs)*sizeof(trttiparaloc)); + + if not assigned(entry^.Data) then + begin + current_asmdata.getglobaldatalabel(loclab); + + loctcb:=ctai_typedconstbuilder.create([tcalo_is_lab,tcalo_make_dead_strippable,tcalo_apply_constalign]); + + loctcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)), targetinfos[target_info.system]^.alignment.recordalignmin, targetinfos[target_info.system]^.alignment.maxCrecordalign); - tcb.emit_ord_const(locs[i].loctype,u8inttype); - tcb.emit_ord_const(locs[i].regsub,u8inttype); - tcb.emit_ord_const(locs[i].regindex,u16inttype); - { the corresponding type for aint is alusinttype } - tcb.emit_ord_const(locs[i].offset,alusinttype); - tcb.end_anonymous_record; - end; - tcb.end_anonymous_record; + loctcb.emit_ord_const(length(locs),u8inttype); + for i:=low(locs) to high(locs) do + begin + loctcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)), + targetinfos[target_info.system]^.alignment.recordalignmin, + targetinfos[target_info.system]^.alignment.maxCrecordalign); + loctcb.emit_ord_const(locs[i].loctype,u8inttype); + loctcb.emit_ord_const(locs[i].regsub,u8inttype); + loctcb.emit_ord_const(locs[i].regindex,u16inttype); + { the corresponding type for aint is alusinttype } + loctcb.emit_ord_const(locs[i].offset,alusinttype); + loctcb.end_anonymous_record; + end; + datadef:=loctcb.end_anonymous_record; + + current_asmdata.asmlists[al_typedconsts].concatList( + loctcb.get_final_asmlist(loclab,datadef,sec_rodata_norel,loclab.name,const_align(sizeof(pint))) + ); + + loctcb.free; + + entry^.data:=loclab; + end + else + loclab:=TAsmLabel(entry^.Data); + + tcb.emit_tai(Tai_const.Create_sym(loclab),voidpointertype); end; @@ -416,13 +453,79 @@ implementation end; - procedure TRTTIWriter.write_record_init_flag(tcb:ttai_typedconstbuilder;value:longword); + function compare_mop_offset_entry(item1,item2:pointer):longint; + var + entry1: pmanagementoperator_offset_entry absolute item1; + entry2: pmanagementoperator_offset_entry absolute item2; begin - { keep this in sync with the type declaration of TRecordInfoInitFlag(s) - in both rttidecl.inc and typinfo.pp } - if target_info.endian=endian_big then - value:=reverse_longword(value); - tcb.emit_ord_const(value,u32inttype); + if entry1^.offsetentry2^.offset then + result:=1 + else + result:=0; + end; + + + procedure TRTTIWriter.write_mop_offset_table(tcb:ttai_typedconstbuilder;def:tabstractrecorddef;mop:tmanagementoperator); + var + list : tfplist; + datatcb : ttai_typedconstbuilder; + tbllbl : TAsmLabel; + entry : pmanagementoperator_offset_entry; + datadef,entrydef : tdef; + i : longint; + pdef : tobjectdef; + begin + list:=tfplist.create; + tabstractrecordsymtable(def.symtable).get_managementoperator_offset_list(mop,list); + if (def.typ=objectdef) then + begin + pdef:=tobjectdef(def).childof; + while assigned(pdef) do + begin + tabstractrecordsymtable(pdef.symtable).get_managementoperator_offset_list(mop,list); + pdef:=pdef.childof; + end; + list.sort(@compare_mop_offset_entry); + end; + if list.count=0 then + tcb.emit_tai(tai_const.create_nil_dataptr,voidpointertype) + else + begin + tcb.start_internal_data_builder(current_asmdata.AsmLists[al_rtti],sec_rodata,'',datatcb,tbllbl); + + datatcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)), + targetinfos[target_info.system]^.alignment.recordalignmin, + targetinfos[target_info.system]^.alignment.maxCrecordalign); + datatcb.emit_ord_const(list.count,u32inttype); + + entrydef:=get_recorddef(itp_init_mop_offset_entry,[voidcodepointertype,sizeuinttype],defaultpacking); + + for i:=0 to list.count-1 do + begin + entry:=pmanagementoperator_offset_entry(list[i]); + + datatcb.maybe_begin_aggregate(entrydef); + + datatcb.queue_init(voidcodepointertype); + datatcb.queue_emit_proc(entry^.pd); + + datatcb.queue_init(sizeuinttype); + datatcb.queue_emit_ordconst(entry^.offset,sizeuinttype); + + datatcb.maybe_end_aggregate(entrydef); + + dispose(entry); + end; + + datadef:=datatcb.end_anonymous_record; + + tcb.finish_internal_data_builder(datatcb,tbllbl,datadef,sizeof(pint)); + + tcb.emit_tai(tai_const.Create_sym(tbllbl),voidpointertype); + end; + list.free; end; @@ -1213,10 +1316,8 @@ implementation { store rtti management operators only for init table } if (rt=initrtti) then begin - riif:=0; - if def.has_non_trivial_init_child(false) then - riif:=riif or riifNonTrivialChild; - write_record_init_flag(tcb,riif); + { for now records don't have the initializer table } + tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype); if (trecordsymtable(def.symtable).managementoperators=[]) then tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype) else @@ -1369,12 +1470,11 @@ implementation { pointer to management operators available only for initrtti } if (rt=initrtti) then begin - riif:=0; - if def.has_non_trivial_init_child(false) then - riif:=riif or riifNonTrivialChild; - if assigned(def.childof) and def.childof.has_non_trivial_init_child(true) then - riif:=riif or riifParentHasNonTrivialChild; - write_record_init_flag(tcb,riif); + { initializer table only available for classes currently } + if def.objecttype=odt_class then + write_mop_offset_table(tcb,def,mop_initialize) + else + tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype); tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype); end; { enclosing record takes care of alignment } @@ -1905,7 +2005,6 @@ implementation current_module.add_extern_asmsym(s,AB_EXTERNAL,AT_DATA); end; - procedure TRTTIWriter.write_rtti(def:tdef;rt:trttitype); var tcb: ttai_typedconstbuilder; diff --git a/compiler/ncgvmt.pas b/compiler/ncgvmt.pas index 74d3f1dc75..ab93c7fe07 100644 --- a/compiler/ncgvmt.pas +++ b/compiler/ncgvmt.pas @@ -69,15 +69,6 @@ interface procedure intf_create_vtbl(tcb: ttai_typedconstbuilder; AImplIntf: TImplementedInterface; intfindex: longint); procedure intf_gen_intf_ref(tcb: ttai_typedconstbuilder; AImplIntf: TImplementedInterface; intfindex: longint; interfaceentrydef, interfaceentrytypedef: tdef); procedure intf_write_table(tcb: ttai_typedconstbuilder; out lab: TAsmLabel; out intftabledef: trecorddef); - { get a table def of the form - record - count: countdef; - elements: array[0..count-1] of elementdef - end; - Returns both the outer record and the inner arraydef - } - procedure gettabledef(prefix: tinternaltypeprefix; countdef, elementdef: tdef; count: longint; packrecords: shortint; out recdef: trecorddef; out arrdef: tarraydef); - function getrecorddef(prefix: tinternaltypeprefix; const fields: array of tdef; packrecords: shortint): trecorddef; { generates the message tables for a class } procedure genstrmsgtab(tcb: ttai_typedconstbuilder; out lab: tasmlabel; out msgstrtabledef: trecorddef); procedure genintmsgtab(tcb: ttai_typedconstbuilder; out lab: tasmlabel; out msginttabledef: trecorddef); @@ -302,7 +293,7 @@ implementation Instead of 0 as the upper bound, use the actual upper bound } msgstrentry:=search_system_type('TMSGSTRTABLE').typedef; - gettabledef(itp_vmt_tstringmesssagetable,s32inttype,msgstrentry,count,0,msgstrtabledef,msgarraydef); + get_tabledef(itp_vmt_tstringmesssagetable,s32inttype,msgstrentry,count,0,msgstrtabledef,msgarraydef); { outer record (TStringMessageTable) } datatcb.maybe_begin_aggregate(msgstrtabledef); datatcb.emit_tai(Tai_const.Create_32bit(count),s32inttype); @@ -356,7 +347,7 @@ implementation method : codepointer; end; } - msginttabledef:=getrecorddef(itp_vmt_intern_msgint_table,[u32inttype,voidcodepointertype],0); + msginttabledef:=get_recorddef(itp_vmt_intern_msgint_table,[u32inttype,voidcodepointertype],0); { from objpas.inc: TMsgInt = record count : longint; @@ -364,7 +355,7 @@ implementation end; } tcb.start_internal_data_builder(current_asmdata.AsmLists[al_const],sec_rodata,_class.vmt_mangledname,datatcb,lab); - gettabledef(itp_vmt_msgint_table_entries,s32inttype,msginttabledef,count,0,msgintdef,msgintarrdef); + get_tabledef(itp_vmt_msgint_table_entries,s32inttype,msginttabledef,count,0,msgintdef,msgintarrdef); datatcb.maybe_begin_aggregate(msgintdef); datatcb.emit_tai(Tai_const.Create_32bit(count),s32inttype); if assigned(root) then @@ -549,7 +540,7 @@ implementation addr : codepointer; end; } - lists.methodnamerec:=getrecorddef(itp_vmt_intern_tmethodnamerec,[cpointerdef.getreusable(cshortstringtype),voidcodepointertype],1); + lists.methodnamerec:=get_recorddef(itp_vmt_intern_tmethodnamerec,[cpointerdef.getreusable(cshortstringtype),voidcodepointertype],1); { from objpas.inc: tmethodnametable = packed record count : dword; @@ -557,7 +548,7 @@ implementation end; } tcb.start_internal_data_builder(current_asmdata.AsmLists[al_const],sec_rodata,_class.vmt_mangledname,lists.pubmethodstcb,lab); - gettabledef(itp_vmt_intern_tmethodnametable,u32inttype,lists.methodnamerec,count,1,pubmethodsdef,pubmethodsarraydef); + get_tabledef(itp_vmt_intern_tmethodnametable,u32inttype,lists.methodnamerec,count,1,pubmethodsdef,pubmethodsarraydef); { begin tmethodnametable } lists.pubmethodstcb.maybe_begin_aggregate(pubmethodsdef); { emit count field } @@ -881,63 +872,6 @@ implementation end; - procedure TVMTWriter.gettabledef(prefix: tinternaltypeprefix; countdef, elementdef: tdef; count: longint; packrecords: shortint; out recdef: trecorddef; out arrdef: tarraydef); - var - fields: tfplist; - name: TIDString; - srsym: tsym; - srsymtable: tsymtable; - begin - { already created a message string table with this number of elements - in this unit -> reuse the def } - name:=internaltypeprefixName[prefix]+tostr(count); - if searchsym_type(copy(name,2,length(name)),srsym,srsymtable) then - begin - recdef:=trecorddef(ttypesym(srsym).typedef); - arrdef:=tarraydef(trecordsymtable(recdef.symtable).findfieldbyoffset(countdef.size).vardef); - exit - end; - recdef:=crecorddef.create_global_internal(name,packrecords, - targetinfos[target_info.system]^.alignment.recordalignmin, - targetinfos[target_info.system]^.alignment.maxCrecordalign); - fields:=tfplist.create; - fields.add(countdef); - if count>0 then - begin - arrdef:=carraydef.create(0,count-1,sizeuinttype); - arrdef.elementdef:=elementdef; - fields.add(arrdef); - end - else - arrdef:=nil; - recdef.add_fields_from_deflist(fields); - fields.free; - end; - - - function TVMTWriter.getrecorddef(prefix: tinternaltypeprefix; const fields: array of tdef; packrecords: shortint): trecorddef; - var - fieldlist: tfplist; - srsym: tsym; - srsymtable: tsymtable; - i: longint; - begin - if searchsym_type(copy(internaltypeprefixName[prefix],2,length(internaltypeprefixName[prefix])),srsym,srsymtable) then - begin - result:=trecorddef(ttypesym(srsym).typedef); - exit - end; - fieldlist:=tfplist.create; - for i:=low(fields) to high(fields) do - fieldlist.add(fields[i]); - result:=crecorddef.create_global_internal(internaltypeprefixName[prefix],packrecords, - targetinfos[target_info.system]^.alignment.recordalignmin, - targetinfos[target_info.system]^.alignment.maxCrecordalign); - result.add_fields_from_deflist(fieldlist); - fieldlist.free; - end; - - { Write interface identifiers to the data section } procedure TVMTWriter.writeinterfaceids(list: TAsmList); var diff --git a/compiler/ppu.pas b/compiler/ppu.pas index 10c42e7eb8..8b381b0a5e 100644 --- a/compiler/ppu.pas +++ b/compiler/ppu.pas @@ -43,7 +43,7 @@ type {$endif Test_Double_checksum} const - CurrentPPUVersion = 201; + CurrentPPUVersion = 202; { unit flags } uf_init = $000001; { unit has initialization section } diff --git a/compiler/symconst.pas b/compiler/symconst.pas index a5ae7e0fb9..3d5bb86a4d 100644 --- a/compiler/symconst.pas +++ b/compiler/symconst.pas @@ -734,6 +734,7 @@ type itp_rtti_set_outer, itp_rtti_set_inner, itp_init_record_operators, + itp_init_mop_offset_entry, itp_threadvar_record, itp_objc_method_list, itp_objc_proto_list, @@ -873,6 +874,7 @@ inherited_objectoptions : tobjectoptions = [oo_has_virtual,oo_has_private,oo_has '$rtti_set_outer$', '$rtti_set_inner$', '$init_record_operators$', + '$init_mop_offset_entry$', '$threadvar_record$', '$objc_method_list$', '$objc_proto_list$', diff --git a/compiler/symdef.pas b/compiler/symdef.pas index 4a260c46b9..c146f3336f 100644 --- a/compiler/symdef.pas +++ b/compiler/symdef.pas @@ -1206,6 +1206,15 @@ interface function getparaencoding(def:tdef):tstringencoding; inline; function get_threadvar_record(def: tdef; out index_field, non_mt_data_field: tsym): trecorddef; + function get_recorddef(prefix:tinternaltypeprefix;const fields:array of tdef; packrecords:shortint): trecorddef; + { get a table def of the form + record + count: countdef; + elements: array[0..count-1] of elementdef + end; + Returns both the outer record and the inner arraydef + } + procedure get_tabledef(prefix:tinternaltypeprefix;countdef,elementdef:tdef;count:longint;packrecords:shortint;out recdef:trecorddef;out arrdef:tarraydef); implementation @@ -1320,6 +1329,79 @@ implementation end; + function get_recorddef(prefix:tinternaltypeprefix; const fields:array of tdef; packrecords:shortint): trecorddef; + var + fieldlist: tfplist; + srsym: tsym; + srsymtable: tsymtable; + i: longint; + name : TIDString; + begin + name:=copy(internaltypeprefixName[prefix],2,length(internaltypeprefixName[prefix])); + if searchsym_type(name,srsym,srsymtable) then + begin + result:=trecorddef(ttypesym(srsym).typedef); + exit + end; + { also always search in the current module (symtables are popped for + RTTI related code already) } + if searchsym_in_module(pointer(current_module),name,srsym,srsymtable) then + begin + result:=trecorddef(ttypesym(srsym).typedef); + exit; + end; + fieldlist:=tfplist.create; + for i:=low(fields) to high(fields) do + fieldlist.add(fields[i]); + result:=crecorddef.create_global_internal(internaltypeprefixName[prefix],packrecords, + targetinfos[target_info.system]^.alignment.recordalignmin, + targetinfos[target_info.system]^.alignment.maxCrecordalign); + result.add_fields_from_deflist(fieldlist); + fieldlist.free; + end; + + + procedure get_tabledef(prefix:tinternaltypeprefix;countdef,elementdef:tdef;count:longint;packrecords:shortint;out recdef:trecorddef;out arrdef:tarraydef); + var + fields: tfplist; + name: TIDString; + srsym: tsym; + srsymtable: tsymtable; + begin + { already created a message string table with this number of elements + in this unit -> reuse the def } + name:=internaltypeprefixName[prefix]+tostr(count); + if searchsym_type(copy(name,2,length(name)),srsym,srsymtable) then + begin + recdef:=trecorddef(ttypesym(srsym).typedef); + arrdef:=tarraydef(trecordsymtable(recdef.symtable).findfieldbyoffset(countdef.size).vardef); + exit + end; + { also always search in the current module (symtables are popped for + RTTI related code already) } + if searchsym_in_module(pointer(current_module),copy(name,2,length(name)),srsym,srsymtable) then + begin + recdef:=trecorddef(ttypesym(srsym).typedef); + arrdef:=tarraydef(trecordsymtable(recdef.symtable).findfieldbyoffset(countdef.size).vardef); + exit; + end; + recdef:=crecorddef.create_global_internal(name,packrecords, + targetinfos[target_info.system]^.alignment.recordalignmin, + targetinfos[target_info.system]^.alignment.maxCrecordalign); + fields:=tfplist.create; + fields.add(countdef); + if count>0 then + begin + arrdef:=carraydef.create(0,count-1,sizeuinttype); + arrdef.elementdef:=elementdef; + fields.add(arrdef); + end + else + arrdef:=nil; + recdef.add_fields_from_deflist(fields); + fields.free; + end; + function make_mangledname(const typeprefix:TSymStr;st:TSymtable;const suffix:TSymStr):TSymStr; var s, diff --git a/compiler/symtable.pas b/compiler/symtable.pas index 796b2d6736..cd1374d995 100644 --- a/compiler/symtable.pas +++ b/compiler/symtable.pas @@ -91,6 +91,12 @@ interface tllvmshadowsymtable = class; {$endif llvm} + tmanagementoperator_offset_entry = record + pd : tprocdef; + offset : asizeint; + end; + pmanagementoperator_offset_entry = ^tmanagementoperator_offset_entry; + tabstractrecordsymtable = class(tstoredsymtable) {$ifdef llvm} private @@ -104,6 +110,7 @@ interface padalignment : shortint; { size to a multiple of which the symtable has to be rounded up } recordalignmin, { local equivalents of global settings, so that records can } maxCrecordalign: shortint; { be created with custom settings internally } + has_fields_with_mop : tmanagementoperators; { whether any of the fields has the need for a management operator (or one of the field's fields) } constructor create(const n:string;usealign,recordminalign,recordmaxCalign:shortint); destructor destroy;override; procedure ppuload(ppufile:tcompilerppufile);override; @@ -120,6 +127,10 @@ interface function is_packed: boolean; function has_single_field(out def:tdef): boolean; function get_unit_symtable: tsymtable; + { collects all management operators of the specified type in list (which + is not cleared); the entries are copies and thus must be freed by the + caller } + procedure get_managementoperator_offset_list(mop:tmanagementoperator;list:tfplist); protected { size in bytes including padding } _datasize : asizeint; @@ -128,8 +139,12 @@ interface databitsize : asizeint; { size in bytes of padding } _paddingsize : word; + { array of tmanagementoperator_offset_entry lists; only assigned if + they had been queried once by get_management_operator_list } + mop_list : array[tmanagementoperator] of tfplist; procedure setdatasize(val: asizeint); function getfieldoffset(sym: tfieldvarsym; base: asizeint; var globalfieldalignment: shortint): asizeint; + procedure do_get_managementoperator_offset_list(data:tobject;arg:pointer); public function iscurrentunit: boolean; override; property datasize : asizeint read _datasize write setdatasize; @@ -479,7 +494,6 @@ implementation TStoredSymtable *****************************************************************************} - constructor tstoredsymtable.create(const s:string); begin inherited create(s); @@ -1161,11 +1175,22 @@ implementation destructor tabstractrecordsymtable.destroy; + var + mop : tmanagementoperator; + mopofs : pmanagementoperator_offset_entry; + i : longint; begin {$ifdef llvm} if refcount=1 then fllvmst.free; {$endif llvm} + for mop in tmanagementoperator do + begin + if assigned(mop_list[mop]) then + for i:=0 to mop_list[mop].count-1 do + dispose(pmanagementoperator_offset_entry(mop_list[mop][i])); + mop_list[mop].free; + end; inherited destroy; end; @@ -1179,6 +1204,7 @@ implementation recordalignmin:=shortint(ppufile.getbyte); if (usefieldalignment=C_alignment) then fieldalignment:=shortint(ppufile.getbyte); + ppufile.getsmallset(has_fields_with_mop); inherited ppuload(ppufile); end; @@ -1196,6 +1222,10 @@ implementation ppufile.putbyte(byte(recordalignmin)); if (usefieldalignment=C_alignment) then ppufile.putbyte(byte(fieldalignment)); + { it's not really a "symtableoption", but loading this from the record + def requires storing the set in the recorddef at least between + ppuload and deref/derefimpl } + ppufile.putsmallset(has_fields_with_mop); ppufile.writeentry(ibrecsymtableoptions); inherited ppuwrite(ppufile); @@ -1259,6 +1289,11 @@ implementation sym.visibility:=vis; { this symbol can't be loaded to a register } sym.varregable:=vr_none; + { management operators } + if sym.vardef.typ in [recorddef,objectdef] then + has_fields_with_mop:=has_fields_with_mop + tabstractrecordsymtable(tabstractrecorddef(sym.vardef).symtable).has_fields_with_mop; + if sym.vardef.typ=recorddef then + has_fields_with_mop:=has_fields_with_mop + trecordsymtable(trecorddef(sym.vardef).symtable).managementoperators; { Calculate field offset } l:=sym.getsize; vardef:=sym.vardef; @@ -1608,6 +1643,74 @@ implementation result:=result.defowner.owner; end; + + procedure tabstractrecordsymtable.do_get_managementoperator_offset_list(data:tobject;arg:pointer); + var + sym : tsym absolute data; + fsym : tfieldvarsym absolute data; + mop : tmanagementoperator absolute arg; + entry : pmanagementoperator_offset_entry; + sublist : tfplist; + i : longint; + begin + if sym.typ<>fieldvarsym then + exit; + if not is_record(fsym.vardef) and not is_object(fsym.vardef) and not is_cppclass(fsym.vardef) then + exit; + if not assigned(mop_list[mop]) then + internalerror(2018082303); + + if is_record(fsym.vardef) then + begin + if mop in trecordsymtable(trecorddef(fsym.vardef).symtable).managementoperators then + begin + new(entry); + entry^.pd:=search_management_operator(mop,fsym.vardef); + if not assigned(entry^.pd) then + internalerror(2018082302); + entry^.offset:=fsym.fieldoffset; + mop_list[mop].add(entry); + end; + end; + + sublist:=tfplist.create; + tabstractrecordsymtable(tabstractrecorddef(fsym.vardef).symtable).get_managementoperator_offset_list(mop,sublist); + for i:=0 to sublist.count-1 do + begin + entry:=pmanagementoperator_offset_entry(sublist[i]); + entry^.offset:=entry^.offset+fsym.fieldoffset; + mop_list[mop].add(entry); + end; + { we don't need to remove the entries as they become part of list } + sublist.free; + end; + + procedure tabstractrecordsymtable.get_managementoperator_offset_list(mop:tmanagementoperator;list:tfplist); + var + i : longint; + entry,entrycopy : pmanagementoperator_offset_entry; + begin + if not assigned(list) then + internalerror(2018082301); + if mop=mop_none then + exit; + if not (mop in has_fields_with_mop) then + { none of the fields or one of the field's fields has the requested operator } + exit; + if not assigned(mop_list[mop]) then + begin + mop_list[mop]:=tfplist.create; + SymList.ForEachCall(@do_get_managementoperator_offset_list,pointer(ptruint(mop))); + end; + for i:=0 to mop_list[mop].count-1 do + begin + entry:=pmanagementoperator_offset_entry(mop_list[mop][i]); + New(entrycopy); + entrycopy^:=entry^; + list.add(entrycopy); + end; + end; + procedure tabstractrecordsymtable.setdatasize(val: asizeint); begin _datasize:=val; diff --git a/compiler/utils/ppuutils/ppudump.pp b/compiler/utils/ppuutils/ppudump.pp index 74fde5c6c2..434c462706 100644 --- a/compiler/utils/ppuutils/ppudump.pp +++ b/compiler/utils/ppuutils/ppudump.pp @@ -654,6 +654,8 @@ end; Read Routines ****************************************************************************} +function readmanagementoperatoroptions(const space : string;const name : string):tmanagementoperators;forward; + procedure readrecsymtableoptions; var usefieldalignment : shortint; @@ -669,6 +671,7 @@ begin writeln([space,' recordalignmin: ',shortint(ppufile.getbyte)]); if (usefieldalignment=C_alignment) then writeln([space,' fieldalignment: ',shortint(ppufile.getbyte)]); + readmanagementoperatoroptions(space,'Fields have MOPs'); end; procedure readsymtableoptions(const s: string); @@ -2330,7 +2333,7 @@ end; -function readmanagementoperatoroptions(const space : string):tmanagementoperators; +function readmanagementoperatoroptions(const space : string;const name : string):tmanagementoperators; { type is in unit symconst } { Management operator options tmanagementoperator=( @@ -2366,7 +2369,8 @@ begin if first then begin write(space); - write('Management operators: '); + write(name); + write(': '); first:=false; end else @@ -3360,7 +3364,7 @@ begin objdef.Size:=getasizeint; writeln([space,' DataSize : ',objdef.Size]); writeln([space,' PaddingSize : ',getword]); - readmanagementoperatoroptions(space); + readmanagementoperatoroptions(space,'Management operators'); end; {read the record definitions and symbols} if not(df_copied_def in current_defoptions) then diff --git a/rtl/inc/objpas.inc b/rtl/inc/objpas.inc index 63e4944aad..f98b5359cc 100644 --- a/rtl/inc/objpas.inc +++ b/rtl/inc/objpas.inc @@ -382,8 +382,9 @@ {$ifndef VER3_0} var vmt : PVmt; - temp : pointer; - flags : TRecordInfoInitFlags; + inittable : pointer; + mopinittable : PRTTIRecordOpOffsetTable; + i : longint; {$endif VER3_0} begin { the size is saved at offset 0 } @@ -397,23 +398,22 @@ {$ifndef VER3_0} { for management operators like initialize call int_initialize } vmt := PVmt(self); - while vmt<>nil do + if assigned(vmt) then begin - Temp:= vmt^.vInitTable; - if assigned(Temp) then + inittable:=vmt^.vInitTable; + if assigned(inittable) then begin - flags:=RecordRTTIInitFlags(Temp); - if riifNonTrivialChild in flags then - { The RTTI format matches one for records, except the type - is tkClass. Since RecordRTTI does not check the type, - calling it yields the desired result. } - RecordRTTI(Instance,Temp,@int_initialize); - { no need to continue complex initializing up the inheritance - tree if none of the parents require it anyway } - if not (riifParentHasNonTrivialChild in flags) then - break; + mopinittable:=RTTIRecordMopInitTable(inittable); + if assigned(mopinittable) then + begin + {$push} + { ensure that no range check errors pop up with the [0..0] array } + {$R-} + for i:=0 to mopinittable^.Count-1 do + TRTTIRecVarOp(mopinittable^.Entries[i].ManagmentOperator)(PByte(Instance)+mopinittable^.Entries[i].FieldOffset); + {$pop} + end; end; - vmt:= vmt^.vParent; end; {$endif VER3_0} diff --git a/rtl/inc/rtti.inc b/rtl/inc/rtti.inc index e1c1d57e0f..46cae4c2dd 100644 --- a/rtl/inc/rtti.inc +++ b/rtl/inc/rtti.inc @@ -138,10 +138,10 @@ end; {$ifndef VER3_0} -function RecordRTTIInitFlags(ti: Pointer): TRecordInfoInitFlags; +function RTTIRecordMopInitTable(ti: Pointer): PRTTIRecordOpOffsetTable; begin ti:=aligntoqword(ti+2+PByte(ti)[1]); - Result:=PRecordInfoInit(ti)^.Flags; + Result:=PRecordInfoInit(ti)^.InitRecordOpTable; end; {$endif VER3_0} diff --git a/rtl/inc/rttidecl.inc b/rtl/inc/rttidecl.inc index eaf7e24e75..55a4e6cfe6 100644 --- a/rtl/inc/rttidecl.inc +++ b/rtl/inc/rttidecl.inc @@ -92,24 +92,24 @@ type Copy: TRTTIRecCopyOp; end; -{$ifndef VER3_0} -{$push} + TRTTIRecordOpOffsetEntry = +{$ifdef USE_PACKED} + packed +{$endif USE_PACKED} + record + ManagmentOperator: CodePointer; + FieldOffset: SizeUInt; + end; -{ better alignment for TRecordInfoInit } -{ keep in sync with ncgrtti.TRTTIWriter.write_record_init_flag() and typinfo.pp } -{ ToDo: different values for 8/16-bit platforms? } -{$minenumsize 4} -{$packset 4} - - TRecordInfoInitFlag = ( - riifNonTrivialChild, - { only relevant for classes } - riifParentHasNonTrivialChild - ); - TRecordInfoInitFlags = set of TRecordInfoInitFlag; - -{$pop} -{$endif} + TRTTIRecordOpOffsetTable = +{$ifdef USE_PACKED} + packed +{$endif USE_PACKED} + record + Count: LongWord; + Entries: array[0..0] of TRTTIRecordOpOffsetEntry; + end; + PRTTIRecordOpOffsetTable = ^TRTTIRecordOpOffsetTable; TRecordInfoInit= {$ifdef USE_PACKED} @@ -119,7 +119,7 @@ type Terminator: Pointer; Size: Longint; {$ifndef VER3_0} - Flags: TRecordInfoInitFlags; + InitRecordOpTable: PRTTIRecordOpOffsetTable; RecordOp: PRTTIRecordOpVMT; {$endif VER3_0} Count: Longint; @@ -148,7 +148,7 @@ type {$ifndef VER3_0} -function RecordRTTIInitFlags(ti: Pointer): TRecordInfoInitFlags; forward; +function RTTIRecordMopInitTable(ti: Pointer): PRTTIRecordOpOffsetTable; forward; {$endif VER3_0} {$ifdef VER3_0} diff --git a/rtl/objpas/typinfo.pp b/rtl/objpas/typinfo.pp index b5b3526955..d031a26889 100644 --- a/rtl/objpas/typinfo.pp +++ b/rtl/objpas/typinfo.pp @@ -328,15 +328,15 @@ unit TypInfo; {$endif FPC_REQUIRES_PROPER_ALIGNMENT} record private - function GetParaLocs: PParameterLocations; inline; function GetTail: Pointer; inline; function GetNext: PVmtMethodParam; inline; + function GetName: ShortString; inline; public ParamType: PPTypeInfo; Flags: TParamFlags; - Name: ShortString; - { ParaLocs: TParameterLocations; } - property ParaLocs: PParameterLocations read GetParaLocs; + NamePtr: PShortString; + ParaLocs: PParameterLocations; + property Name: ShortString read GetName; property Tail: Pointer read GetTail; property Next: PVmtMethodParam read GetNext; end; @@ -352,15 +352,17 @@ unit TypInfo; function GetResultLocs: PParameterLocations; inline; function GetTail: Pointer; inline; function GetNext: PIntfMethodEntry; inline; + function GetName: ShortString; inline; public ResultType: PPTypeInfo; CC: TCallConv; Kind: TMethodKind; ParamCount: Word; StackSize: SizeInt; - Name: ShortString; + NamePtr: PShortString; { Params: array[0..ParamCount - 1] of TVmtMethodParam } - { ResultLocs: TParameterLocations (if ResultType != Nil) } + { ResultLocs: PParameterLocations (if ResultType != Nil) } + property Name: ShortString read GetName; property Param[Index: Word]: PVmtMethodParam read GetParam; property ResultLocs: PParameterLocations read GetResultLocs; property Tail: Pointer read GetTail; @@ -408,25 +410,24 @@ unit TypInfo; Entries: array[0..0] of TVmtMethodEntry; end; + TRecOpOffsetEntry = + {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} + packed + {$endif FPC_REQUIRES_PROPER_ALIGNMENT} + record + ManagementOperator: CodePointer; + FieldOffset: SizeUInt; + end; -{$ifndef VER3_0} -{$push} - -{ better alignment for TRecordInfoInit } -{ keep in sync with ncgrtti.TRTTIWriter.write_record_init_flag() and rttidecl.inc } -{ ToDo: different values for 8/16-bit platforms? } -{$minenumsize 4} -{$packset 4} - - TRecordInfoInitFlag = ( - riifNonTrivialChild, - { only relevant for classes } - riifParentHasNonTrivialChild - ); - TRecordInfoInitFlags = set of TRecordInfoInitFlag; - -{$pop} -{$endif} + TRecOpOffsetTable = + {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} + packed + {$endif FPC_REQUIRES_PROPER_ALIGNMENT} + record + Count: LongWord; + Entries: array[0..0] of TRecOpOffsetEntry; + end; + PRecOpOffsetTable = ^TRecOpOffsetTable; PRecInitData = ^TRecInitData; TRecInitData = @@ -437,7 +438,7 @@ unit TypInfo; Terminator: Pointer; Size: Integer; {$ifndef VER3_0} - Flags: TRecordInfoInitFlags; + InitOffsetOp: PRecOpOffsetTable; ManagementOp: Pointer; {$endif} ManagedFieldCount: Integer; @@ -2960,14 +2961,9 @@ end; { TVmtMethodParam } -function TVmtMethodParam.GetParaLocs: PParameterLocations; -begin - Result := PParameterLocations(aligntoptr(PByte(@Name[0]) + Length(Name) + Sizeof(Name[0]))); -end; - function TVmtMethodParam.GetTail: Pointer; begin - Result := ParaLocs^.Tail; + Result := PByte(@ParaLocs) + SizeOf(ParaLocs); end; function TVmtMethodParam.GetNext: PVmtMethodParam; @@ -2975,6 +2971,11 @@ begin Result := PVmtMethodParam(aligntoptr(Tail)); end; +function TVmtMethodParam.GetName: ShortString; +begin + Result := NamePtr^; +end; + { TIntfMethodEntry } function TIntfMethodEntry.GetParam(Index: Word): PVmtMethodParam; @@ -2982,39 +2983,24 @@ begin if Index >= ParamCount then Result := Nil else - begin - Result := PVmtMethodParam(aligntoptr(PByte(@Name[0]) + SizeOf(Name[0]) + Length(Name))); - while Index > 0 do - begin - Result := Result^.Next; - Dec(Index); - end; - end; + Result := PVmtMethodParam(PByte(aligntoptr(PByte(@NamePtr) + SizeOf(NamePtr))) + Index * PtrUInt(aligntoptr(Pointer(SizeOf(TVmtMethodParam))))); end; function TIntfMethodEntry.GetResultLocs: PParameterLocations; begin if not Assigned(ResultType) then Result := Nil - else if ParamCount = 0 then - Result := PParameterLocations(aligntoptr(PByte(@Name[0]) + SizeOf(Name[0]) + Length(Name))) else - Result := PParameterLocations(aligntoptr(Param[ParamCount - 1]^.Tail)); + Result := PParameterLocations(PByte(aligntoptr(PByte(@NamePtr) + SizeOf(NamePtr))) + ParamCount * PtrUInt(aligntoptr(Pointer(SizeOf(TVmtMethodParam))))); end; function TIntfMethodEntry.GetTail: Pointer; -var - retloc: PParameterLocations; begin + Result := PByte(@NamePtr) + SizeOf(NamePtr); + if ParamCount > 0 then + Result := PByte(aligntoptr(Result)) + ParamCount * PtrUInt(aligntoptr(Pointer(SizeOf(TVmtMethodParam)))); if Assigned(ResultType) then - begin - retloc := ResultLocs; - Result := PByte(@retloc^.Count) + SizeOf(retloc^.Count) + SizeOf(TParameterLocation) * retloc^.Count; - end - else if ParamCount = 0 then - Result := PByte(@Name[0]) + Length(Name) + SizeOf(Byte) - else - Result := Param[ParamCount - 1]^.Tail; + Result := PByte(aligntoptr(Result)) + SizeOf(PParameterLocations); end; function TIntfMethodEntry.GetNext: PIntfMethodEntry; @@ -3022,6 +3008,11 @@ begin Result := PIntfMethodEntry(aligntoptr(Tail)); end; +function TIntfMethodEntry.GetName: ShortString; +begin + Result := NamePtr^; +end; + { TIntfMethodTable } function TIntfMethodTable.GetMethod(Index: Word): PIntfMethodEntry;