paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-05 18:07:56 +02:00
Code Issues Packages Projects Releases Wiki Activity

The Important Ones:

Browse Source 
- 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 -
This commit is contained in:
marco 2018-09-26 12:50:46 +00:00
parent ced4e6c27d
commit edf32cd5dc
13 changed files with 470 additions and 201 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

53
compiler/aasmcnst.pas
View File

@ -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);

3
compiler/aasmdata.pas
View File

@ -96,7 +96,8 @@ interface
sp_objcprotocolrefs,
sp_varsets,
sp_floats,
sp_guids
sp_guids,
sp_paraloc
);
const

169
compiler/ncgrtti.pas
View File

@ -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^.offset<entry2^.offset then
result:=-1
else if entry1^.offset>entry2^.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;

76
compiler/ncgvmt.pas
View File

@ -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

2
compiler/ppu.pas
View File

@ -43,7 +43,7 @@ type
{$endif Test_Double_checksum}
const
CurrentPPUVersion = 201;
CurrentPPUVersion = 202;
{ unit flags }
uf_init = $000001; { unit has initialization section }

2
compiler/symconst.pas
View File

@ -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$',

82
compiler/symdef.pas
View File

@ -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,

105
compiler/symtable.pas
View File

@ -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;

10
compiler/utils/ppuutils/ppudump.pp
View File

@ -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

32
rtl/inc/objpas.inc
View File

@ -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}

4
rtl/inc/rtti.inc
View File

@ -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}

38
rtl/inc/rttidecl.inc
View File

@ -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}

95
rtl/objpas/typinfo.pp
View File

@ -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;