paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-27 08:13:42 +02:00
Code Issues Packages Projects Releases Wiki Activity
345d83c3e3
fpc/compiler/ncgvmt.pas
svenbarth 345d83c3e3 Merge RTTI changes from packages branch (including adjustments that were required due to changes in trunk since then). These changes favor source backwards compatibility in contrast to Delphi compatibility. Binary compatiblity is however drastically broken due to the indirect references that are platform independant! 
Merged revision(s) 28239-28289 from branches/svenbarth/packages:
Provide the possiblity to switch between the direct and indirect RTTI symbols.

ncgrtti.pas, TRTTIWriter:
  + get_rtti_label, get_rtti_label_ord2str & get_rtti_label_str2ord: add new "indirect" parameter and pass that along to rtti_mangledname
hlcgobj.pas, thlcgobj:
  * g_incrrefcount, g_initialize, g_finalize, g_array_rtti_helper: for now pass along False to get_rtti_label()
ncgvmt.pas, TVMTWriter:
  * writevmt: for now pass along False to get_rtti_label()
ncgld.pas, tcgrttinode:
  * pass_generate_code: for now pass along False to the get_rtti_label*() methods
........
Provide possibility to select between using a direct and an indirect RTTI reference. This way the references can be changed for selected cases.

ncgrtti, TRTTIWriter:
  * ref_rtti: new "indirect" parameter that's relayed to rtti_mangledname()
  * write_rtti_reference: new "indirect" paramater that's relayed to ref_rtti()
........
Switch properties to use the indirect type information without breaking backwards compatiblity. :)

compiler/ncgrtti.pas, TRTTIWriter:
  * published_properties_write_rtti_data: use the indirect reference, not the direct one
rtl/objpas/typinfo.pp:
  * to allow compilation with both 2.6.x and 2.7.1 and too avoid too many ifdefs at least in the declarations we define a macro TypeInfoPtr which is either PTypeInfo (2.6.x) or PPTypeInfo (2.7.1 and newer)
  * TPropInfo: rename PropType to PropTypeRef and change type to TypeInfoPtr
  + TPropInfo: add a new property PropType which returns a PTypeInfo out of the PropTypeRef depending on the compiler version
........
Switch further simple types (sets, enums, class references, pointers) to indirect type information (again without breaking backwards compatibility).

compiler/ncgrtti.pas, TRTTIWriter.write_rtti_data:
  * enumdef_rtti, setdef_rtti, classrefdef_rtti & pointerdef_rtti: write an indirect RTTI reference

rtl/objpas/typinfo.pp, TTypeData:
  * rename BaseType to BaseTypeRef, CompType to CompTypeRef, InstanceType to InstanceTypeRef and RefType to RefTypeRef and change their type to TypeInfoPtr
  + add properties BaseType, CompType, InstanceType & RefType which return a PTypeInfo out of the corresponding *Ref field depending on the compiler version
........
Switch class and interface parent as well as extended type to indirect type information

compiler/ncgrtti.pas, TRTTIWriter:
  * write_rtti_data.objectdef_rtti.objectdef_rtti_class_full: use indirect reference for class parent and extended type
  * write_rtti_data.objectdef_rtti.objectdef_rtti_interface_full: use indirect reference for interface parent

rtl/objpas/typinfo.pp, TTypeData:
  + add new method DerefTypeInfoPtr which returns Nil if the indirect reference is Nil and otherwise returns the dereferences indirect reference (for 2.6.x the direct reference is returned as is)
  * rename ParentInfo to ParentInfoRef, HelperParent to HelperParentRef, ExtendedInfo to ExtendedInfoRef, IntfParent ot IntfParentRef and RawIntfParent to RawIntfParentRef and change their type to TypeInfoPtr
  + introduce ParentInfo, HelperParent, ExtendedInfo, IntfParent and RawIntfParent properties that return a PTypeInfo and use the new DerefTypeInfoPtr to return the correct type info value
  * change the other newly introduced properties of TTypeData to use DerefTypeInfoPtr as well to be on the safe side
........
Switch record/object fields to indirect type information references.

compiler/ncgrtti.pas, TRTTIWriter.fields_write_rtti_data:
  * use the indirect reference for the object parent type
  * use the indirect reference for the field type

rtl/inc/rtti.inc:
  * TRecordElement: change TypeInfo to PPointer for 2.7.1 and newer
  * RecordRTTI: correctly dereference the element type for 2.7.1 and newer
  * fpc_copy: correctly reference the element type for 2.7.1 and newer
........
Switch static arrays to indirect RTTI reference.

compiler/ncgrtti.pas, TRTTIWriter.write_rtti_data:
  * arraydef_rtti: write the dimension types and the final field type as indirect references

rtl/inc/rtti.inc:
  * TArrayInfo: switch ElInfo to PPointer for 2.7.1+
  * ArrayRTTI & fpc_copy: correctly dereference ElInfo for 2.7.1+
rtl/objpas/typinfo.pp, TArrayTypeData:
  * switch ElType and Dims to PPTypeInfo; no backwards compatibility needed here as TArrayTypeData was added in 2.7.1 only

tests/test/trtti8.pp: fix test
........
Switch dynamic arrays to indirect RTTI references.

compiler/ncgrtti.pas, TRTTIWriter.write_rtti_data.arraydef_rtti:
  * write indirect references for the two element entries

rtl/inc/dynarr.inc:
  * tdynarraytypedata: change elType2 to PPointer for 2.7.1+
  * fpc_dynarray_clear, fpc_dynarray_setlength & fpc_dynarray_copy: correctly dereference elType2 for 2.7.1+
rtl/objpas/typinfo.pp, TTypeData:
  * rename elType and elType2 to elTypeRef and elType2Ref respectively and change type to TypeInfoPtr
  * add properties elType and elType2 which return PTypeInfo by dereferencing elTypeRef and elType2Ref respecively correctly
  * remove a few stray "inline" directives in the implementation
........
Switch procedure parameters and result type to indirect RTTI references.

compiler/ncgrtti.pas, TRTTIWriter.write_rtti_data.procvardef_rtti:
  * write_procedure_param: use indirect RTTI reference
  * write result info for both methods and procvars as indirect RTTI reference
  * write parameters for procvars as indirect RTTI reference

rtl/objpas/typinfo.pp:
  * TProcedureParam: change type of ParamType to PPTypeInfo (no backwards compatiblity needed here; was added for 2.7.1)
  * TProcedureSignature: change type of RseultType to PPTypeInfo (no backwards compatibility needed here; was added for 2.7.1)
  * TTypeData: remark in the comments of tkMethod that ResultTypeRef and ParamTypeRefs are of type PPTypeInfo and not PTypeInfo

tests/test/trtti9.pp: 
  * fix test
........
Remove no longer needed "indirect" parameter for TRTTIWriter methods.

ncgrtti.pas, TRTTIWriter:
  - ref_rtti & write_rtti_reference: remove "indirect" parameter
  * ref_rtti: call rtti_mangledname with "indirect" always set to "true"
  - remove "true" parameter on callsites of write_rtti_reference & ref_rtti
........

git-svn-id: trunk@33944 -
2016-06-10 17:01:51 +00:00

1359 lines
53 KiB
ObjectPascal
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

{
Copyright (c) 1998-2002 by Florian Klaempfl
Generates VMT for classes/objects and interface wrappers
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
****************************************************************************
}
unit ncgvmt;
{$i fpcdefs.inc}
interface
uses
aasmdata,aasmbase,aasmcnst,
symbase,symconst,symtype,symdef;
type
pprocdeftree = ^tprocdeftree;
tprocdeftree = record
data : tprocdef;
nl : tasmlabel;
l,r : pprocdeftree;
end;
TVMTWriter=class
protected
_Class : tobjectdef;
{ message tables }
root : pprocdeftree;
{ implemented interface vtables }
fintfvtablelabels: array of TAsmLabel;
procedure disposeprocdeftree(p : pprocdeftree);
procedure insertmsgint(p:TObject;arg:pointer);
procedure insertmsgstr(p:TObject;arg:pointer);
procedure insertint(p : pprocdeftree;var at : pprocdeftree;var count:longint);
procedure insertstr(p : pprocdeftree;var at : pprocdeftree;var count:longint);
function RedirectToEmpty(procdef: tprocdef): boolean;
procedure writenames(tcb: ttai_typedconstbuilder; p: pprocdeftree);
procedure writeintentry(tcb: ttai_typedconstbuilder; p: pprocdeftree; entrydef: tdef);
procedure writestrentry(tcb: ttai_typedconstbuilder; p: pprocdeftree; entrydef: tdef);
{$ifdef WITHDMT}
{ dmt }
procedure insertdmtentry(p:TObject;arg:pointer);
procedure writedmtindexentry(p : pprocdeftree);
procedure writedmtaddressentry(p : pprocdeftree);
{$endif}
{ published methods }
procedure do_count_published_methods(p:TObject;arg:pointer);
procedure do_gen_published_methods(p:TObject;arg:pointer);
{ virtual methods }
procedure writevirtualmethods(tcb: ttai_typedconstbuilder);
{ interface tables }
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);
procedure genpublishedmethodstable(tcb: ttai_typedconstbuilder; out lab: tasmlabel; out pubmethodsdef: trecorddef);
procedure generate_field_table(tcb: ttai_typedconstbuilder; out lab: tasmlabel; out fieldtabledef: trecorddef);
procedure generate_abstract_stub(list:TAsmList;pd:tprocdef); virtual;
{$ifdef WITHDMT}
{ generates a DMT for _class }
function gendmt : tasmlabel;
{$endif WITHDMT}
public
constructor create(c:tobjectdef); virtual;
{ write the VMT to al_globals }
procedure writevmt;
procedure writeinterfaceids(list: TAsmList);
{ should the VMT writer be used at all (e.g., not for the JVM target) }
class function use_vmt_writer: boolean; virtual;
end;
TVMTWriterClass = class of TVMTWriter;
{ generate VMTs }
procedure write_vmts(st:tsymtable;is_global:boolean);
var
CVMTWriter: TVMTWriterClass = TVMTWriter;
implementation
uses
cutils,cclasses,
globtype,globals,verbose,constexp,
systems,fmodule,
symsym,symtable,symcreat,defutil,
{$ifdef cpuhighleveltarget}
pparautl,
{$endif cpuhighleveltarget}
aasmtai,
wpobase,
nobj,
cgbase,parabase,paramgr,cgobj,cgcpu,hlcgobj,hlcgcpu,
ncgrtti;
{*****************************************************************************
TVMTWriter
*****************************************************************************}
constructor TVMTWriter.create(c:tobjectdef);
begin
inherited Create;
_Class:=c;
end;
{**************************************
Message Tables
**************************************}
procedure TVMTWriter.disposeprocdeftree(p : pprocdeftree);
begin
if assigned(p^.l) then
disposeprocdeftree(p^.l);
if assigned(p^.r) then
disposeprocdeftree(p^.r);
dispose(p);
end;
procedure TVMTWriter.insertint(p : pprocdeftree;var at : pprocdeftree;var count:longint);
begin
if at=nil then
begin
at:=p;
inc(count);
end
else
begin
if p^.data.messageinf.i<at^.data.messageinf.i then
insertint(p,at^.l,count)
else if p^.data.messageinf.i>at^.data.messageinf.i then
insertint(p,at^.r,count)
else
Message1(parser_e_duplicate_message_label,tostr(p^.data.messageinf.i));
end;
end;
procedure TVMTWriter.insertstr(p : pprocdeftree;var at : pprocdeftree;var count:longint);
var
i : integer;
begin
if at=nil then
begin
at:=p;
inc(count);
end
else
begin
i:=CompareStr(p^.data.messageinf.str^,at^.data.messageinf.str^);
if i<0 then
insertstr(p,at^.l,count)
else if i>0 then
insertstr(p,at^.r,count)
else
Message1(parser_e_duplicate_message_label,p^.data.messageinf.str^);
end;
end;
procedure TVMTWriter.insertmsgint(p:TObject;arg:pointer);
var
i : longint;
pd : Tprocdef;
pt : pprocdeftree;
begin
if tsym(p).typ<>procsym then
exit;
for i:=0 to Tprocsym(p).ProcdefList.Count-1 do
begin
pd:=tprocdef(Tprocsym(p).ProcdefList[i]);
if po_msgint in pd.procoptions then
begin
new(pt);
pt^.data:=pd;
pt^.l:=nil;
pt^.r:=nil;
insertint(pt,root,plongint(arg)^);
end;
end;
end;
procedure TVMTWriter.insertmsgstr(p:TObject;arg:pointer);
var
i : longint;
pd : Tprocdef;
pt : pprocdeftree;
begin
if tsym(p).typ<>procsym then
exit;
for i:=0 to Tprocsym(p).ProcdefList.Count-1 do
begin
pd:=tprocdef(Tprocsym(p).ProcdefList[i]);
if po_msgstr in pd.procoptions then
begin
new(pt);
pt^.data:=pd;
pt^.l:=nil;
pt^.r:=nil;
insertstr(pt,root,plongint(arg)^);
end;
end;
end;
procedure TVMTWriter.writenames(tcb: ttai_typedconstbuilder; p: pprocdeftree);
var
ca : pchar;
len : byte;
datatcb : ttai_typedconstbuilder;
begin
if assigned(p^.l) then
writenames(tcb,p^.l);
tcb.start_internal_data_builder(current_asmdata.AsmLists[al_const],sec_rodata_norel,'',datatcb,p^.nl);
len:=length(p^.data.messageinf.str^);
datatcb.maybe_begin_aggregate(carraydef.getreusable(cansichartype,len+1));
datatcb.emit_tai(tai_const.create_8bit(len),cansichartype);
getmem(ca,len+1);
move(p^.data.messageinf.str^[1],ca^,len);
ca[len]:=#0;
datatcb.emit_tai(Tai_string.Create_pchar(ca,len),carraydef.getreusable(cansichartype,len));
datatcb.maybe_end_aggregate(carraydef.getreusable(cansichartype,len+1));
tcb.finish_internal_data_builder(datatcb,p^.nl,carraydef.getreusable(cansichartype,len+1),sizeof(pint));
if assigned(p^.r) then
writenames(tcb,p^.r);
end;
procedure TVMTWriter.writestrentry(tcb: ttai_typedconstbuilder; p: pprocdeftree; entrydef: tdef);
begin
if assigned(p^.l) then
writestrentry(tcb,p^.l,entrydef);
{ write name label }
tcb.maybe_begin_aggregate(entrydef);
tcb.emit_tai(Tai_const.Create_sym(p^.nl),cpointerdef.getreusable(carraydef.getreusable(cansichartype,length(p^.data.messageinf.str^)+1)));
tcb.queue_init(voidcodepointertype);
tcb.queue_emit_proc(p^.data);
tcb.maybe_end_aggregate(entrydef);
if assigned(p^.r) then
writestrentry(tcb,p^.r,entrydef);
end;
procedure TVMTWriter.genstrmsgtab(tcb: ttai_typedconstbuilder; out lab: tasmlabel; out msgstrtabledef: trecorddef);
var
count : longint;
datatcb: ttai_typedconstbuilder;
msgstrentry: tdef;
msgarraydef: tarraydef;
begin
root:=nil;
count:=0;
{ insert all message handlers into a tree, sorted by name }
_class.symtable.SymList.ForEachCall(@insertmsgstr,@count);
{ write all names }
if assigned(root) then
writenames(tcb,root);
{ now start writing the message string table }
tcb.start_internal_data_builder(current_asmdata.AsmLists[al_const],sec_rodata,'',datatcb,lab);
{
TStringMessageTable = record
count : longint;
msgstrtable : array[0..0] of tmsgstrtable;
end;
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);
{ outer record (TStringMessageTable) }
datatcb.maybe_begin_aggregate(msgstrtabledef);
datatcb.emit_tai(Tai_const.Create_32bit(count),s32inttype);
if assigned(root) then
begin
{ array of TMsgStrTable }
datatcb.maybe_begin_aggregate(msgarraydef);
writestrentry(datatcb,root,msgstrentry);
datatcb.maybe_end_aggregate(msgarraydef);
disposeprocdeftree(root);
end;
datatcb.maybe_end_aggregate(msgstrtabledef);
tcb.finish_internal_data_builder(datatcb,lab,msgstrtabledef,sizeof(pint));
end;
procedure TVMTWriter.writeintentry(tcb: ttai_typedconstbuilder; p: pprocdeftree; entrydef: tdef);
begin
if assigned(p^.l) then
writeintentry(tcb,p^.l,entrydef);
tcb.maybe_begin_aggregate(entrydef);
{ write integer dispatch number }
tcb.emit_tai(Tai_const.Create_32bit(p^.data.messageinf.i),u32inttype);
tcb.queue_init(voidcodepointertype);
tcb.queue_emit_proc(p^.data);
tcb.maybe_end_aggregate(entrydef);
if assigned(p^.r) then
writeintentry(tcb,p^.r,entrydef);
end;
procedure TVMTWriter.genintmsgtab(tcb: ttai_typedconstbuilder; out lab: tasmlabel; out msginttabledef: trecorddef);
var
count : longint;
datatcb: ttai_typedconstbuilder;
msgintdef: trecorddef;
msgintarrdef: tarraydef;
begin
root:=nil;
count:=0;
{ insert all message handlers into a tree, sorted by name }
_class.symtable.SymList.ForEachCall(@insertmsgint,@count);
{ now start writing of the message string table }
{ from objpas.inc:
TMsgIntTable = record
index : dword;
method : codepointer;
end;
}
msginttabledef:=getrecorddef(itp_vmt_intern_msgint_table,[u32inttype,voidcodepointertype],0);
{ from objpas.inc:
TMsgInt = record
count : longint;
msgs : array[0..0] of TMsgIntTable;
end;
}
tcb.start_internal_data_builder(current_asmdata.AsmLists[al_const],sec_rodata,'',datatcb,lab);
gettabledef(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
begin
datatcb.maybe_begin_aggregate(msgintarrdef);
writeintentry(datatcb,root,msginttabledef);
datatcb.maybe_end_aggregate(msgintarrdef);
disposeprocdeftree(root);
end;
datatcb.maybe_end_aggregate(msgintdef);
tcb.finish_internal_data_builder(datatcb,lab,msgintdef,sizeof(pint));
end;
{$ifdef WITHDMT}
{**************************************
DMT
**************************************}
procedure TVMTWriter.insertdmtentry(p:TObject;arg:pointer);
var
hp : tprocdef;
pt : pprocdeftree;
begin
if tsym(p).typ=procsym then
begin
hp:=tprocsym(p).definition;
while assigned(hp) do
begin
if (po_msgint in hp.procoptions) then
begin
new(pt);
pt^.p:=hp;
pt^.l:=nil;
pt^.r:=nil;
insertint(pt,root);
end;
hp:=hp.nextoverloaded;
end;
end;
end;
procedure TVMTWriter.writedmtindexentry(p : pprocdeftree);
begin
if assigned(p^.l) then
writedmtindexentry(p^.l);
al_globals.concat(Tai_const.Create_32bit(p^.data.messageinf.i));
if assigned(p^.r) then
writedmtindexentry(p^.r);
end;
procedure TVMTWriter.writedmtaddressentry(p : pprocdeftree);
begin
if assigned(p^.l) then
writedmtaddressentry(p^.l);
al_globals.concat(Tai_const_symbol.Createname(p^.data.mangledname,0));
if assigned(p^.r) then
writedmtaddressentry(p^.r);
end;
function TVMTWriter.gendmt : tasmlabel;
var
r : tasmlabel;
begin
root:=nil;
count:=0;
gendmt:=nil;
{ insert all message handlers into a tree, sorted by number }
_class.symtable.SymList.ForEachCall(insertdmtentry);
if count>0 then
begin
current_asmdata.getglobaldatalabel(r);
gendmt:=r;
al_globals.concat(cai_align.create(const_align(sizeof(pint))));
al_globals.concat(Tai_label.Create(r));
{ entries for caching }
al_globals.concat(Tai_const.Create_ptr(0));
al_globals.concat(Tai_const.Create_ptr(0));
al_globals.concat(Tai_const.Create_32bit(count));
if assigned(root) then
begin
writedmtindexentry(root);
writedmtaddressentry(root);
disposeprocdeftree(root);
end;
end;
end;
{$endif WITHDMT}
{**************************************
Published Methods
**************************************}
procedure TVMTWriter.do_count_published_methods(p:TObject;arg:pointer);
var
i : longint;
pd : tprocdef;
begin
if (tsym(p).typ<>procsym) then
exit;
for i:=0 to Tprocsym(p).ProcdefList.Count-1 do
begin
pd:=tprocdef(Tprocsym(p).ProcdefList[i]);
if (pd.procsym=tsym(p)) and
(pd.visibility=vis_published) then
inc(plongint(arg)^);
end;
end;
type
tvmtasmoutput = record
pubmethodstcb: ttai_typedconstbuilder;
methodnamerec: trecorddef;
end;
pvmtasmoutput = ^tvmtasmoutput;
procedure TVMTWriter.do_gen_published_methods(p:TObject;arg:pointer);
var
i : longint;
l : tasmlabel;
pd : tprocdef;
lists: pvmtasmoutput absolute arg;
datatcb : ttai_typedconstbuilder;
namedef : tdef;
begin
if (tsym(p).typ<>procsym) then
exit;
for i:=0 to Tprocsym(p).ProcdefList.Count-1 do
begin
pd:=tprocdef(Tprocsym(p).ProcdefList[i]);
if (pd.procsym=tsym(p)) and
(pd.visibility=vis_published) then
begin
{ l: name_of_method }
lists^.pubmethodstcb.start_internal_data_builder(current_asmdata.AsmLists[al_const],sec_rodata_norel,'',datatcb,l);
namedef:=datatcb.emit_shortstring_const(tsym(p).realname);
lists^.pubmethodstcb.finish_internal_data_builder(datatcb,l,namedef,sizeof(pint));
{ the tmethodnamerec }
lists^.pubmethodstcb.maybe_begin_aggregate(lists^.methodnamerec);
{ convert the pointer to the name into a generic pshortstring,
so all entries can share the same recorddef }
lists^.pubmethodstcb.queue_init(charpointertype);
lists^.pubmethodstcb.queue_emit_asmsym(l,namedef);
if po_abstractmethod in pd.procoptions then
lists^.pubmethodstcb.emit_tai(Tai_const.Create_nil_codeptr,voidcodepointertype)
else
begin
{ convert the procdef in a generic voidcodepointer, same
reason as above }
lists^.pubmethodstcb.queue_init(voidcodepointertype);
lists^.pubmethodstcb.queue_emit_proc(pd);
end;
lists^.pubmethodstcb.maybe_end_aggregate(lists^.methodnamerec);
end;
end;
end;
procedure TVMTWriter.genpublishedmethodstable(tcb: ttai_typedconstbuilder; out lab: tasmlabel; out pubmethodsdef: trecorddef);
var
count : longint;
lists : tvmtasmoutput;
pubmethodsarraydef: tarraydef;
begin
count:=0;
_class.symtable.SymList.ForEachCall(@do_count_published_methods,@count);
if count>0 then
begin
{ in the list of the published methods (from objpas.inc):
tmethodnamerec = packed record
name : pshortstring;
addr : codepointer;
end;
}
lists.methodnamerec:=getrecorddef(itp_vmt_intern_tmethodnamerec,[cpointerdef.getreusable(cshortstringtype),voidcodepointertype],1);
{ from objpas.inc:
tmethodnametable = packed record
count : dword;
entries : packed array[0..0] of tmethodnamerec;
end;
}
tcb.start_internal_data_builder(current_asmdata.AsmLists[al_const],sec_rodata,'',lists.pubmethodstcb,lab);
gettabledef(itp_vmt_intern_tmethodnametable,u32inttype,lists.methodnamerec,count,1,pubmethodsdef,pubmethodsarraydef);
{ begin tmethodnametable }
lists.pubmethodstcb.maybe_begin_aggregate(pubmethodsdef);
{ emit count field }
lists.pubmethodstcb.emit_tai(Tai_const.Create_32bit(count),u32inttype);
{ begin entries field (array) }
lists.pubmethodstcb.maybe_begin_aggregate(pubmethodsarraydef);
{ add all entries elements }
_class.symtable.SymList.ForEachCall(@do_gen_published_methods,@lists);
{ end entries field (array) }
lists.pubmethodstcb.maybe_end_aggregate(pubmethodsarraydef);
{ end methodnametable }
lists.pubmethodstcb.maybe_end_aggregate(pubmethodsdef);
tcb.finish_internal_data_builder(lists.pubmethodstcb,lab,pubmethodsdef,sizeof(pint));
end
else
begin
lab:=nil;
pubmethodsdef:=nil;
end;
end;
procedure TVMTWriter.generate_field_table(tcb: ttai_typedconstbuilder; out lab: tasmlabel; out fieldtabledef: trecorddef);
var
i : longint;
sym : tsym;
classtable : tasmlabel;
classindex,
fieldcount : longint;
classtablelist : TFPList;
datatcb: ttai_typedconstbuilder;
packrecords: longint;
classdef: tobjectdef;
classtabledef: trecorddef;
begin
classtablelist:=TFPList.Create;
{ retrieve field info fields }
fieldcount:=0;
for i:=0 to _class.symtable.SymList.Count-1 do
begin
sym:=tsym(_class.symtable.SymList[i]);
if (sym.typ=fieldvarsym) and
not(sp_static in sym.symoptions) and
(sym.visibility=vis_published) then
begin
if tfieldvarsym(sym).vardef.typ<>objectdef then
internalerror(200611032);
classindex:=classtablelist.IndexOf(tfieldvarsym(sym).vardef);
if classindex=-1 then
classtablelist.Add(tfieldvarsym(sym).vardef);
inc(fieldcount);
end;
end;
if fieldcount>0 then
begin
if (tf_requires_proper_alignment in target_info.flags) then
packrecords:=0
else
packrecords:=1;
{ generate the class table }
tcb.start_internal_data_builder(current_asmdata.AsmLists[al_const],sec_rodata,'',datatcb,classtable);
datatcb.begin_anonymous_record('$fpc_intern_classtable_'+tostr(classtablelist.Count-1),
packrecords,1,
targetinfos[target_info.system]^.alignment.recordalignmin,
targetinfos[target_info.system]^.alignment.maxCrecordalign);
datatcb.emit_tai(Tai_const.Create_16bit(classtablelist.count),u16inttype);
for i:=0 to classtablelist.Count-1 do
begin
classdef:=tobjectdef(classtablelist[i]);
{ type of the field }
datatcb.queue_init(voidpointertype);
{ reference to the vmt }
datatcb.queue_emit_asmsym(
current_asmdata.RefAsmSymbol(classdef.vmt_mangledname,AT_DATA),
tfieldvarsym(classdef.vmt_field).vardef);
end;
classtabledef:=datatcb.end_anonymous_record;
tcb.finish_internal_data_builder(datatcb,classtable,classtabledef,sizeof(pint));
{ write fields }
{
TFieldTable =
$ifndef FPC_REQUIRES_PROPER_ALIGNMENT
packed
$endif FPC_REQUIRES_PROPER_ALIGNMENT
record
FieldCount: Word;
ClassTable: Pointer;
Fields: array[0..0] of TFieldInfo
end;
}
tcb.start_internal_data_builder(current_asmdata.AsmLists[al_const],sec_rodata,'',datatcb,lab);
{ can't easily specify a name here for reuse of the constructed def,
since it's full of variable length shortstrings (-> all of those
lengths and their order would have to incorporated in the name,
plus there would be very little chance that it could actually be
reused }
datatcb.begin_anonymous_record('',packrecords,1,
targetinfos[target_info.system]^.alignment.recordalignmin,
targetinfos[target_info.system]^.alignment.maxCrecordalign);
datatcb.emit_tai(Tai_const.Create_16bit(fieldcount),u16inttype);
datatcb.emit_tai(Tai_const.Create_sym(classtable),cpointerdef.getreusable(classtabledef));
for i:=0 to _class.symtable.SymList.Count-1 do
begin
sym:=tsym(_class.symtable.SymList[i]);
if (sym.typ=fieldvarsym) and
not(sp_static in sym.symoptions) and
(sym.visibility=vis_published) then
begin
{
TFieldInfo =
$ifndef FPC_REQUIRES_PROPER_ALIGNMENT
packed
$endif FPC_REQUIRES_PROPER_ALIGNMENT
record
FieldOffset: PtrUInt;
ClassTypeIndex: Word;
Name: ShortString;
end;
}
datatcb.begin_anonymous_record('$fpc_intern_fieldinfo_'+tostr(length(tfieldvarsym(sym).realname)),packrecords,1,
targetinfos[target_info.system]^.alignment.recordalignmin,
targetinfos[target_info.system]^.alignment.maxCrecordalign);
datatcb.emit_tai(Tai_const.Create_pint(tfieldvarsym(sym).fieldoffset),ptruinttype);
classindex:=classtablelist.IndexOf(tfieldvarsym(sym).vardef);
if classindex=-1 then
internalerror(200611033);
datatcb.emit_tai(Tai_const.Create_16bit(classindex+1),u16inttype);
datatcb.emit_shortstring_const(tfieldvarsym(sym).realname);
datatcb.end_anonymous_record;
end;
end;
fieldtabledef:=datatcb.end_anonymous_record;
tcb.finish_internal_data_builder(datatcb,lab,fieldtabledef,sizeof(pint));
end
else
begin
fieldtabledef:=nil;
lab:=nil;
end;
classtablelist.free;
end;
{**************************************
Interface tables
**************************************}
procedure TVMTWriter.intf_create_vtbl(tcb: ttai_typedconstbuilder; AImplIntf: TImplementedInterface; intfindex: longint);
var
datatcb : ttai_typedconstbuilder;
pd : tprocdef;
hs : TSymStr;
i : longint;
begin
tcb.start_internal_data_builder(current_asmdata.AsmLists[al_const],sec_rodata,'',datatcb,fintfvtablelabels[intfindex]);
datatcb.begin_anonymous_record('',0,1,
targetinfos[target_info.system]^.alignment.recordalignmin,
targetinfos[target_info.system]^.alignment.maxCrecordalign);
if assigned(AImplIntf.procdefs) then
begin
for i:=0 to AImplIntf.procdefs.count-1 do
begin
pd:=tprocdef(AImplIntf.procdefs[i]);
hs:=make_mangledname('WRPR',_class.owner,_class.objname^+'_$_'+AImplIntf.IntfDef.objname^+'_$_'+
tostr(i)+'_$_'+pd.mangledname);
{ create reference }
datatcb.emit_tai(Tai_const.Createname(hs,AT_FUNCTION,0),cprocvardef.getreusableprocaddr(pd));
end;
end
else
{ can't have an empty symbol on LLVM }
datatcb.emit_tai(tai_const.Create_nil_codeptr,voidpointertype);
tcb.finish_internal_data_builder(datatcb,fintfvtablelabels[intfindex],
datatcb.end_anonymous_record,sizeof(pint));
end;
procedure TVMTWriter.intf_gen_intf_ref(tcb: ttai_typedconstbuilder; AImplIntf: TImplementedInterface; intfindex: longint; interfaceentrydef, interfaceentrytypedef: tdef);
var
pd: tprocdef;
begin
tcb.maybe_begin_aggregate(interfaceentrydef);
{ GUID (or nil for Corba interfaces) }
if AImplIntf.IntfDef.objecttype in [odt_interfacecom] then
tcb.emit_tai(Tai_const.CreateName(
make_mangledname('IID',AImplIntf.IntfDef.owner,AImplIntf.IntfDef.objname^),AT_DATA,0),cpointerdef.getreusable(rec_tguid))
else
tcb.emit_tai(Tai_const.Create_nil_dataptr,cpointerdef.getreusable(rec_tguid));
{ VTable }
tcb.queue_init(voidpointertype);
tcb.queue_emit_asmsym(fintfvtablelabels[intfindex],AImplIntf.VtblImplIntf.IntfDef);
{ IOffset field }
case AImplIntf.VtblImplIntf.IType of
etFieldValue, etFieldValueClass,
etStandard:
tcb.emit_tai(Tai_const.Create_pint(AImplIntf.VtblImplIntf.IOffset),ptruinttype);
etStaticMethodResult, etStaticMethodClass:
begin
pd:=tprocdef(tpropertysym(AImplIntf.ImplementsGetter).propaccesslist[palt_read].procdef);
tcb.queue_init(ptruinttype);
tcb.queue_emit_proc(pd);
end;
etVirtualMethodResult, etVirtualMethodClass:
begin
pd:=tprocdef(tpropertysym(AImplIntf.ImplementsGetter).propaccesslist[palt_read].procdef);
tcb.emit_tai(Tai_const.Create_pint(tobjectdef(pd.struct).vmtmethodoffset(pd.extnumber)),ptruinttype);
end;
else
internalerror(200802162);
end;
{ IIDStr }
tcb.queue_init(cpointerdef.getreusable(cshortstringtype));
tcb.queue_emit_asmsym(
current_asmdata.RefAsmSymbol(
make_mangledname('IIDSTR',AImplIntf.IntfDef.owner,AImplIntf.IntfDef.objname^),
AT_DATA),
cpointerdef.getreusable(carraydef.getreusable(cansichartype,length(AImplIntf.IntfDef.iidstr^)+1)));
{ IType }
tcb.emit_ord_const(aint(AImplIntf.VtblImplIntf.IType),interfaceentrytypedef);
tcb.maybe_end_aggregate(interfaceentrydef);
end;
procedure TVMTWriter.intf_write_table(tcb: ttai_typedconstbuilder; out lab: TAsmLabel; out intftabledef: trecorddef);
var
i : longint;
ImplIntf : TImplementedInterface;
datatcb : ttai_typedconstbuilder;
interfaceentrydef : tdef;
interfaceentrytypedef: tdef;
interfacearray: tdef;
begin
setlength(fintfvtablelabels,_class.ImplementedInterfaces.count);
{ Write unique vtbls }
for i:=0 to _class.ImplementedInterfaces.count-1 do
begin
ImplIntf:=TImplementedInterface(_class.ImplementedInterfaces[i]);
if ImplIntf.VtblImplIntf=ImplIntf then
intf_create_vtbl(tcb,ImplIntf,i)
end;
{ Set labels for aliased vtbls (after all unique vtbls have been
written, so all labels have been defined already) }
for i:=0 to _class.ImplementedInterfaces.count-1 do
begin
ImplIntf:=TImplementedInterface(_class.ImplementedInterfaces[i]);
if ImplIntf.VtblImplIntf<>ImplIntf then
fintfvtablelabels[i]:=fintfvtablelabels[_class.ImplementedInterfaces.IndexOf(ImplIntf.VtblImplIntf)];
end;
tcb.start_internal_data_builder(current_asmdata.AsmLists[al_const],sec_rodata,'',datatcb,lab);
datatcb.begin_anonymous_record('',default_settings.packrecords,1,
targetinfos[target_info.system]^.alignment.recordalignmin,
targetinfos[target_info.system]^.alignment.maxCrecordalign);
datatcb.emit_tai(Tai_const.Create_pint(_class.ImplementedInterfaces.count),search_system_type('SIZEUINT').typedef);
interfaceentrydef:=search_system_type('TINTERFACEENTRY').typedef;
interfaceentrytypedef:=search_system_type('TINTERFACEENTRYTYPE').typedef;
interfacearray:=carraydef.getreusable(interfaceentrydef,_class.ImplementedInterfaces.count);
datatcb.maybe_begin_aggregate(interfacearray);
{ Write vtbl references }
for i:=0 to _class.ImplementedInterfaces.count-1 do
begin
ImplIntf:=TImplementedInterface(_class.ImplementedInterfaces[i]);
intf_gen_intf_ref(datatcb,ImplIntf,i,interfaceentrydef,interfaceentrytypedef);
end;
datatcb.maybe_end_aggregate(interfacearray);
intftabledef:=datatcb.end_anonymous_record;
tcb.finish_internal_data_builder(datatcb,lab,intftabledef,intftabledef.alignment);
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,ptruinttype);
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
s : string;
tcb : ttai_typedconstbuilder;
def : tdef;
begin
if assigned(_class.iidguid) then
begin
s:=make_mangledname('IID',_class.owner,_class.objname^);
tcb:=ctai_typedconstbuilder.create([tcalo_make_dead_strippable]);
tcb.emit_guid_const(_class.iidguid^);
list.concatlist(tcb.get_final_asmlist(
current_asmdata.DefineAsmSymbol(s,AB_GLOBAL,AT_DATA),
rec_tguid,
sec_rodata,
s,
const_align(sizeof(pint))));
tcb.free;
end;
s:=make_mangledname('IIDSTR',_class.owner,_class.objname^);
tcb:=ctai_typedconstbuilder.create([tcalo_make_dead_strippable]);
def:=tcb.emit_shortstring_const(_class.iidstr^);
list.concatlist(tcb.get_final_asmlist(
current_asmdata.DefineAsmSymbol(s,AB_GLOBAL,AT_DATA),
def,
sec_rodata,
s,
sizeof(pint)));
tcb.free;
end;
class function TVMTWriter.use_vmt_writer: boolean;
begin
result:=true;
end;
function TVMTWriter.RedirectToEmpty(procdef : tprocdef) : boolean;
var
i : longint;
hp : PCGParaLocation;
begin
result:=false;
if procdef.isempty then
begin
{$ifdef x86}
paramanager.create_funcretloc_info(procdef,calleeside);
if (procdef.funcretloc[calleeside].Location^.loc=LOC_FPUREGISTER) then
exit;
{$endif x86}
procdef.init_paraloc_info(callerside);
{ we can redirect the call if no memory parameter is passed }
for i:=0 to procdef.paras.count-1 do
begin
hp:=tparavarsym(procdef.paras[i]).paraloc[callerside].Location;
while assigned(hp) do
begin
if not(hp^.Loc in [LOC_REGISTER,LOC_MMREGISTER,LOC_FPUREGISTER]) then
exit;
hp:=hp^.Next;
end;
end;
result:=true;
end;
end;
procedure TVMTWriter.generate_abstract_stub(list:TAsmList;pd:tprocdef);
var
sym: TAsmSymbol;
begin
{ Generate stubs for abstract methods, so their symbols are present and
can be used e.g. to take address (see issue #24536). }
if (po_global in pd.procoptions) and
(pd.owner.defowner<>self._class) then
exit;
sym:=current_asmdata.GetAsmSymbol(pd.mangledname);
if assigned(sym) and (sym.bind<>AB_EXTERNAL) then
exit;
maybe_new_object_file(list);
new_section(list,sec_code,lower(pd.mangledname),target_info.alignment.procalign);
if (po_global in pd.procoptions) then
begin
sym:=current_asmdata.DefineAsmSymbol(pd.mangledname,AB_GLOBAL,AT_FUNCTION);
list.concat(Tai_symbol.Create_global(sym,0));
end
else
begin
sym:=current_asmdata.DefineAsmSymbol(pd.mangledname,AB_LOCAL,AT_FUNCTION);
list.concat(Tai_symbol.Create(sym,0));
end;
hlcg.g_external_wrapper(list,pd,'FPC_ABSTRACTERROR');
list.concat(Tai_symbol_end.Create(sym));
end;
procedure TVMTWriter.writevirtualmethods(tcb: ttai_typedconstbuilder);
var
vmtpd : tprocdef;
vmtentry : pvmtentry;
i : longint;
procname : TSymStr;
{$ifdef vtentry}
hs : string;
{$endif vtentry}
begin
if not assigned(_class.VMTEntries) then
exit;
for i:=0 to _class.VMTEntries.Count-1 do
begin
vmtentry:=pvmtentry(_class.vmtentries[i]);
vmtpd:=vmtentry^.procdef;
{ safety checks }
if not(po_virtualmethod in vmtpd.procoptions) then
internalerror(200611082);
if vmtpd.extnumber<>i then
internalerror(200611083);
if (po_abstractmethod in vmtpd.procoptions) then
begin
procname:='FPC_ABSTRACTERROR';
generate_abstract_stub(current_asmdata.AsmLists[al_procedures],vmtpd);
end
else if (cs_opt_remove_emtpy_proc in current_settings.optimizerswitches) and RedirectToEmpty(vmtpd) then
procname:='FPC_EMPTYMETHOD'
else if not wpoinfomanager.optimized_name_for_vmt(_class,vmtpd,procname) then
procname:=vmtpd.mangledname;
tcb.emit_tai(Tai_const.Createname(procname,AT_FUNCTION,0),cprocvardef.getreusableprocaddr(vmtpd));
{$ifdef vtentry}
hs:='VTENTRY'+'_'+_class.vmt_mangledname+'$$'+tostr(_class.vmtmethodoffset(i) div sizeof(pint));
current_asmdata.asmlists[al_globals].concat(tai_symbol.CreateName(hs,AT_DATA,0));
{$endif vtentry}
end;
end;
procedure TVMTWriter.writevmt;
var
methodnametable,intmessagetable,
strmessagetable,classnamelabel,
fieldtablelabel : tasmlabel;
hs: string;
{$ifdef WITHDMT}
dmtlabel : tasmlabel;
{$endif WITHDMT}
interfacetable : tasmlabel;
tcb, datatcb: ttai_typedconstbuilder;
classnamedef: tdef;
methodnametabledef,
fieldtabledef,
interfacetabledef,
strmessagetabledef,
intmessagetabledef: trecorddef;
parentvmtdef: tdef;
pinterfacetabledef,
pstringmessagetabledef: tdef;
vmttypesym: ttypesym;
vmtdef: tdef;
begin
{$ifdef WITHDMT}
dmtlabel:=gendmt;
{$endif WITHDMT}
{ this code gets executed after the current module's symtable has
already been removed from the symtablestack -> add it again, so that
newly created defs here end up in the right unit }
symtablestack.push(current_module.localsymtable);
strmessagetable:=nil;
interfacetable:=nil;
fieldtablelabel:=nil;
methodnametable:=nil;
intmessagetable:=nil;
classnamelabel:=nil;
classnamedef:=nil;
methodnametabledef:=nil;
fieldtabledef:=nil;
interfacetabledef:=nil;
strmessagetabledef:=nil;
intmessagetabledef:=nil;
{ generate VMT }
tcb:=ctai_typedconstbuilder.create([tcalo_make_dead_strippable]);
{ write tables for classes, this must be done before the actual
class is written, because we need the labels defined }
if is_class(_class) then
begin
{ write class name }
tcb.start_internal_data_builder(current_asmdata.asmlists[al_const],sec_rodata_norel,'',datatcb,classnamelabel);
classnamedef:=datatcb.emit_shortstring_const(_class.RttiName);
tcb.finish_internal_data_builder(datatcb,classnamelabel,classnamedef,sizeof(pint));
{ interface table }
if _class.ImplementedInterfaces.count>0 then
intf_write_table(tcb,interfacetable,interfacetabledef);
genpublishedmethodstable(tcb,methodnametable,methodnametabledef);
generate_field_table(tcb,fieldtablelabel,fieldtabledef);
{ generate message and dynamic tables }
if (oo_has_msgstr in _class.objectoptions) then
genstrmsgtab(tcb,strmessagetable,strmessagetabledef);
if (oo_has_msgint in _class.objectoptions) then
genintmsgtab(tcb,intmessagetable,intmessagetabledef);
end;
{ reuse the type created in nobj, so we get internal consistency
checking for free }
vmttypesym:=try_search_current_module_type(internaltypeprefixName[itp_vmtdef]+_class.mangledparaname);
if not assigned(vmttypesym) or
(vmttypesym.typedef.typ<>recorddef) then
internalerror(2015071403);
vmtdef:=trecorddef(vmttypesym.typedef);
tcb.maybe_begin_aggregate(vmtdef);
{ determine the size with symtable.datasize, because }
{ size gives back 4 for classes }
tcb.emit_ord_const(tObjectSymtable(_class.symtable).datasize,ptrsinttype);
tcb.emit_ord_const(-int64(tObjectSymtable(_class.symtable).datasize),ptrsinttype);
{$ifdef WITHDMT}
if _class.classtype=ct_object then
begin
if assigned(dmtlabel) then
tcb.emit_tai(dmtlabel,voidpointertype)
else
tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype);
end;
{$endif WITHDMT}
{ write pointer to parent VMT, this isn't implemented in TP }
{ but this is not used in FPC ? (PM) }
{ it's not used yet, but the delphi-operators as and is need it (FK) }
{ it is not written for parents that don't have any vmt !! }
if is_class(_class) then
parentvmtdef:=cpointerdef.getreusable(search_system_type('TVMT').typedef)
else
parentvmtdef:=voidpointertype;
if assigned(_class.childof) and
(oo_has_vmt in _class.childof.objectoptions) then
begin
tcb.queue_init(parentvmtdef);
tcb.queue_emit_asmsym(
current_asmdata.RefAsmSymbol(_class.childof.vmt_mangledname,AT_DATA),
tfieldvarsym(_class.childof.vmt_field).vardef);
end
else
tcb.emit_tai(Tai_const.Create_nil_dataptr,parentvmtdef);
{ write extended info for classes, for the order see rtl/inc/objpash.inc }
if is_class(_class) then
begin
{ pointer to class name string }
tcb.queue_init(cpointerdef.getreusable(cshortstringtype));
tcb.queue_emit_asmsym(classnamelabel,classnamedef);
{ pointer to dynamic table or nil }
if (oo_has_msgint in _class.objectoptions) then
begin
tcb.queue_init(voidpointertype);
tcb.queue_emit_asmsym(intmessagetable,cpointerdef.getreusable(intmessagetabledef));
end
else
tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype);
{ pointer to method table or nil }
if assigned(methodnametable) then
begin
tcb.queue_init(voidpointertype);
tcb.queue_emit_asmsym(methodnametable,cpointerdef.getreusable(methodnametabledef))
end
else
tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype);
{ pointer to field table }
if assigned(fieldtablelabel) then
begin
tcb.queue_init(voidpointertype);
tcb.queue_emit_asmsym(fieldtablelabel,fieldtabledef)
end
else
tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype);
{ pointer to type info of published section }
tcb.emit_tai(Tai_const.Create_sym(RTTIWriter.get_rtti_label(_class,fullrtti,false)),voidpointertype);
{ inittable for con-/destruction }
if _class.members_need_inittable then
tcb.emit_tai(Tai_const.Create_sym(RTTIWriter.get_rtti_label(_class,initrtti,false)),voidpointertype)
else
tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype);
{ auto table }
tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype);
{ interface table }
pinterfacetabledef:=search_system_type('PINTERFACETABLE').typedef;
if _class.ImplementedInterfaces.count>0 then
begin
tcb.queue_init(pinterfacetabledef);
tcb.queue_emit_asmsym(interfacetable,interfacetabledef)
end
else if _class.implements_any_interfaces then
tcb.emit_tai(Tai_const.Create_nil_dataptr,pinterfacetabledef)
else
begin
tcb.queue_init(pinterfacetabledef);
tcb.queue_emit_asmsym(current_asmdata.RefAsmSymbol('FPC_EMPTYINTF',AT_DATA),ptruinttype);
end;
{ table for string messages }
pstringmessagetabledef:=search_system_type('PSTRINGMESSAGETABLE').typedef;
if (oo_has_msgstr in _class.objectoptions) then
begin
tcb.queue_init(voidpointertype);
tcb.queue_emit_asmsym(strmessagetable,pstringmessagetabledef);
end
else
tcb.emit_tai(Tai_const.Create_nil_dataptr,pstringmessagetabledef);
end;
{ write virtual methods }
writevirtualmethods(tcb);
tcb.emit_tai(Tai_const.Create_nil_codeptr,voidcodepointertype);
tcb.maybe_end_aggregate(vmtdef);
{ concatenate the VMT to the asmlist }
current_asmdata.asmlists[al_globals].concatlist(
tcb.get_final_asmlist(
current_asmdata.DefineAsmSymbol(_class.vmt_mangledname,AB_GLOBAL,AT_DATA),
vmtdef,sec_rodata,_class.vmt_mangledname,const_align(sizeof(pint))
)
);
tcb.free;
{$ifdef vtentry}
{ write vtinherit symbol to notify the linker of the class inheritance tree }
hs:='VTINHERIT'+'_'+_class.vmt_mangledname+'$$';
if assigned(_class.childof) then
hs:=hs+_class.childof.vmt_mangledname
else
hs:=hs+_class.vmt_mangledname;
current_asmdata.asmlists[al_globals].concat(tai_symbol.CreateName(hs,AT_DATA,0));
{$endif vtentry}
symtablestack.pop(current_module.localsymtable);
{ write indirect symbol }
tcb:=ctai_typedconstbuilder.create([tcalo_make_dead_strippable]);
hs:=_class.vmt_mangledname;
tcb.emit_tai(Tai_const.Createname(hs,AT_DATA,0),voidpointertype);
current_asmdata.AsmLists[al_globals].concatList(
tcb.get_final_asmlist(
current_asmdata.DefineAsmSymbol(hs,AB_INDIRECT,AT_DATA),
voidpointertype,sec_rodata,hs,const_align(sizeof(pint))));
tcb.free;
end;
procedure gen_intf_wrapper(list:TAsmList;_class:tobjectdef);
var
i,j : longint;
tmps : string;
pd : TProcdef;
ImplIntf : TImplementedInterface;
{$ifdef cpuhighleveltarget}
wrapperpd: tprocdef;
wrapperinfo: pskpara_interface_wrapper;
{$endif cpuhighleveltarget}
begin
for i:=0 to _class.ImplementedInterfaces.count-1 do
begin
ImplIntf:=TImplementedInterface(_class.ImplementedInterfaces[i]);
if (ImplIntf=ImplIntf.VtblImplIntf) and
assigned(ImplIntf.ProcDefs) then
begin
for j:=0 to ImplIntf.ProcDefs.Count-1 do
begin
pd:=TProcdef(ImplIntf.ProcDefs[j]);
{ we don't track method calls via interfaces yet ->
assume that every method called via an interface call
is reachable for now }
if (po_virtualmethod in pd.procoptions) and
not is_objectpascal_helper(tprocdef(pd).struct) then
tobjectdef(tprocdef(pd).struct).register_vmt_call(tprocdef(pd).extnumber);
tmps:=make_mangledname('WRPR',_class.owner,_class.objname^+'_$_'+
ImplIntf.IntfDef.objname^+'_$_'+tostr(j)+'_$_'+pd.mangledname);
{$ifdef cpuhighleveltarget}
{ bare copy so we don't copy the aliasnames }
wrapperpd:=tprocdef(pd.getcopyas(procdef,pc_bareproc));
{ set the mangled name to the wrapper name }
wrapperpd.setmangledname(tmps);
{ insert the wrapper procdef in the current unit's local
symbol table, but set the owning "struct" to the current
class (so self will have the correct type) }
finish_copied_procdef(wrapperpd,tmps,current_module.localsymtable,_class);
{ now insert self/vmt }
insert_self_and_vmt_para(wrapperpd);
{ and the function result }
insert_funcret_para(wrapperpd);
{ recalculate the parameters now that we've added the above }
wrapperpd.calcparas;
{ set the info required to generate the implementation }
wrapperpd.synthetickind:=tsk_interface_wrapper;
new(wrapperinfo);
wrapperinfo^.pd:=pd;
wrapperinfo^.offset:=ImplIntf.ioffset;
wrapperpd.skpara:=wrapperinfo;
{$else cpuhighleveltarget}
{ create wrapper code }
new_section(list,sec_code,tmps,target_info.alignment.procalign);
hlcg.init_register_allocators;
hlcg.g_intf_wrapper(list,pd,tmps,ImplIntf.ioffset);
hlcg.done_register_allocators;
{$endif cpuhighleveltarget}
end;
end;
end;
end;
procedure do_write_vmts(st:tsymtable;is_global:boolean);
var
i : longint;
def : tdef;
vmtwriter : TVMTWriter;
begin
if not CVMTWriter.use_vmt_writer then
exit;
for i:=0 to st.DefList.Count-1 do
begin
def:=tdef(st.DefList[i]);
case def.typ of
recorddef :
do_write_vmts(trecorddef(def).symtable,is_global);
objectdef :
begin
{ Skip generics and forward defs }
if ([df_generic,df_genconstraint]*def.defoptions<>[]) or
(oo_is_forward in tobjectdef(def).objectoptions) then
continue;
do_write_vmts(tobjectdef(def).symtable,is_global);
{ Write also VMT if not done yet }
if not(ds_vmt_written in def.defstates) then
begin
vmtwriter:=CVMTWriter.create(tobjectdef(def));
if is_interface(tobjectdef(def)) then
vmtwriter.writeinterfaceids(current_asmdata.AsmLists[al_globals]);
if (oo_has_vmt in tobjectdef(def).objectoptions) then
vmtwriter.writevmt;
vmtwriter.free;
include(def.defstates,ds_vmt_written);
end;
if is_class(def) then
gen_intf_wrapper(current_asmdata.asmlists[al_globals],tobjectdef(def));
end;
procdef :
begin
if assigned(tprocdef(def).localst) and
(tprocdef(def).localst.symtabletype=localsymtable) then
do_write_vmts(tprocdef(def).localst,false);
if assigned(tprocdef(def).parast) then
do_write_vmts(tprocdef(def).parast,false);
end;
end;
end;
end;
procedure write_vmts(st:tsymtable;is_global:boolean);
begin
create_hlcodegen;
do_write_vmts(st,is_global);
destroy_hlcodegen;
end;
end.
Reference in New Issue View Git Blame Copy Permalink