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

* instead of embedding the attributes inside the class' and property's type data only store a reference to a table of attributes

Browse Source 
git-svn-id: trunk@42365 -
This commit is contained in:
svenbarth 2019-07-12 22:05:29 +00:00
parent 38fad4b5cf
commit d137e06ade
3 changed files with 90 additions and 76 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

80
compiler/ncgrtti.pas
View File

@ -57,7 +57,7 @@ interface
function ref_rtti(def:tdef;rt:trttitype;indirect:boolean;suffix:tsymstr):tasmsymbol; function ref_rtti(def:tdef;rt:trttitype;indirect:boolean;suffix:tsymstr):tasmsymbol;
procedure write_rtti_name(tcb: ttai_typedconstbuilder; def: tdef); procedure write_rtti_name(tcb: ttai_typedconstbuilder; def: tdef);
procedure write_rtti_data(tcb: ttai_typedconstbuilder; def:tdef; rt: trttitype); procedure write_rtti_data(tcb: ttai_typedconstbuilder; def:tdef; rt: trttitype);
procedure write_attribute_data(tcb: ttai_typedconstbuilder; def:tdef); procedure write_attribute_data(tcb: ttai_typedconstbuilder;attr_list:trtti_attribute_list);
procedure write_unit_info_reference(tcb: ttai_typedconstbuilder); procedure write_unit_info_reference(tcb: ttai_typedconstbuilder);
procedure write_child_rtti_data(def:tdef;rt:trttitype); procedure write_child_rtti_data(def:tdef;rt:trttitype);
procedure write_rtti_reference(tcb: ttai_typedconstbuilder; def: tdef; rt: trttitype); procedure write_rtti_reference(tcb: ttai_typedconstbuilder; def: tdef; rt: trttitype);
@ -761,9 +761,6 @@ implementation
proctypesinfo : byte; proctypesinfo : byte;
propnameitem : tpropnamelistitem; propnameitem : tpropnamelistitem;
propdefname : string; propdefname : string;
attridx: ShortInt;
attrcount: byte;
attr: trtti_attribute;
procedure writeaccessproc(pap:tpropaccesslisttypes; shiftvalue : byte; unsetvalue: byte); procedure writeaccessproc(pap:tpropaccesslisttypes; shiftvalue : byte; unsetvalue: byte);
var var
@ -909,22 +906,12 @@ implementation
tcb.emit_ord_const(propnameitem.propindex,u16inttype); tcb.emit_ord_const(propnameitem.propindex,u16inttype);
tcb.emit_ord_const(proctypesinfo,u8inttype); tcb.emit_ord_const(proctypesinfo,u8inttype);
{ Write property attribute count } { write reference to attribute table }
if assigned(tpropertysym(sym).rtti_attribute_list) then write_attribute_data(tcb,tpropertysym(sym).rtti_attribute_list);
attrcount:=tpropertysym(sym).rtti_attribute_list.get_attribute_count
else
attrcount:=0;
tcb.emit_ord_const(attrcount,u8inttype);
{ Write property name } { Write property name }
tcb.emit_shortstring_const(tpropertysym(sym).realname); tcb.emit_shortstring_const(tpropertysym(sym).realname);
{ Write property attributes }
for attridx := 0 to attrcount-1 do
begin
attr := trtti_attribute(tpropertysym(sym).rtti_attribute_list.rtti_attributes[attridx]);
tcb.emit_tai(Tai_const.Createname(attr.symbolname,AT_DATA_FORCEINDIRECT,0), cpointerdef.getreusable(ttypesym(attr.typesym).typedef));
end;
tcb.end_anonymous_record; tcb.end_anonymous_record;
end; end;
end; end;
@ -1583,7 +1570,7 @@ implementation
{ TAttributeData } { TAttributeData }
if rmo_hasattributes in current_module.rtti_options then if rmo_hasattributes in current_module.rtti_options then
write_attribute_data(tcb, def); write_attribute_data(tcb, def.rtti_attribute_list);
{ write published properties for this object } { write published properties for this object }
published_properties_write_rtti_data(tcb,propnamelist,def.symtable); published_properties_write_rtti_data(tcb,propnamelist,def.symtable);
@ -1746,26 +1733,57 @@ implementation
end; end;
end; end;
procedure TRTTIWriter.write_attribute_data(tcb: ttai_typedconstbuilder; def: tdef); procedure TRTTIWriter.write_attribute_data(tcb:ttai_typedconstbuilder;attr_list:trtti_attribute_list);
var var
count: word; count, i: word;
idx: byte; attr : trtti_attribute;
attr: trtti_attribute; tbltcb : ttai_typedconstbuilder;
tbllab : tasmlabel;
tbldef : tdef;
begin begin
if (def.typ = objectdef) and (assigned(tobjectdef(def).rtti_attribute_list)) then if assigned(attr_list) then
count:=tobjectdef(def).rtti_attribute_list.get_attribute_count count:=attr_list.get_attribute_count
else else
count:=0; count:=0;
tcb.emit_ord_const(count,u16inttype); if count=0 then
begin
{ write a Nil reference }
tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype);
exit;
end;
if count>0 then { first write the attribute list as a separate table }
for idx:=0 to count-1 do current_asmdata.getglobaldatalabel(tbllab);
begin
attr := trtti_attribute(tobjectdef(def).rtti_attribute_list.rtti_attributes[idx]); tbltcb:=ctai_typedconstbuilder.create([tcalo_is_lab,tcalo_make_dead_strippable,tcalo_apply_constalign]);
tcb.emit_tai(Tai_const.Createname(attr.symbolname,AT_DATA_FORCEINDIRECT,0), cpointerdef.getreusable(ttypesym(attr.typesym).typedef));
end; tbltcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)),
end; targetinfos[target_info.system]^.alignment.recordalignmin,
targetinfos[target_info.system]^.alignment.maxCrecordalign);
tbltcb.emit_ord_const(count,u16inttype);
for i:=0 to count-1 do
begin
tbltcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)),
targetinfos[target_info.system]^.alignment.recordalignmin,
targetinfos[target_info.system]^.alignment.maxCrecordalign);
attr:=trtti_attribute(attr_list.rtti_attributes[i]);
tbltcb.emit_tai(tai_const.Createname(attr.symbolname,AT_DATA_FORCEINDIRECT,0),cpointerdef.getreusable(ttypesym(attr.typesym).typedef));
tbltcb.end_anonymous_record;
end;
tbldef:=tbltcb.end_anonymous_record;
current_asmdata.asmlists[al_rtti].concatlist(
tbltcb.get_final_asmlist(tbllab,tbldef,sec_rodata,tbllab.name,const_align(sizeof(pint)))
);
tbltcb.free;
{ write the reference to the attribute table }
tcb.emit_tai(Tai_const.Create_sym(tbllab),voidpointertype);
end;
procedure TRTTIWriter.write_unit_info_reference(tcb: ttai_typedconstbuilder); procedure TRTTIWriter.write_unit_info_reference(tcb: ttai_typedconstbuilder);
begin begin

18
packages/rtl-objpas/src/inc/rtti.pp
View File

@ -3398,13 +3398,16 @@ end;
function TRttiProperty.GetAttributes: specialize TArray<TCustomAttribute>; function TRttiProperty.GetAttributes: specialize TArray<TCustomAttribute>;
var var
i: Integer; i: Integer;
ad: PAttributeData;
begin begin
if not FAttributesResolved then if not FAttributesResolved then
begin begin
setlength(FAttributes,FPropInfo^.AttributeCount); ad := FPropInfo^.AttributeTable;
for i := 0 to FPropInfo^.AttributeCount-1 do if Assigned(ad) then
begin begin
FAttributes[i]:=TCustomAttribute(GetPropAttribute(FPropInfo,i)); SetLength(FAttributes, FPropInfo^.AttributeTable^.AttributeCount);
for i := 0 to High(FAttributes) do
FAttributes[i] := TCustomAttribute(GetPropAttribute(FPropInfo, i));
end; end;
FAttributesResolved:=true; FAttributesResolved:=true;
end; end;
@ -3631,9 +3634,12 @@ begin
if not FAttributesResolved then if not FAttributesResolved then
begin begin
ad := GetAttributeData(FTypeInfo); ad := GetAttributeData(FTypeInfo);
setlength(FAttributes,ad^.AttributeCount); if Assigned(ad) then
for i := 0 to ad^.AttributeCount-1 do begin
FAttributes[i]:=GetAttribute(ad,i); setlength(FAttributes,ad^.AttributeCount);
for i := 0 to ad^.AttributeCount-1 do
FAttributes[i]:=GetAttribute(ad,i);
end;
FAttributesResolved:=true; FAttributesResolved:=true;
end; end;
result := FAttributes; result := FAttributes;

68
rtl/objpas/typinfo.pp
View File

@ -526,6 +526,20 @@ unit TypInfo;
{ PropertyTable: TPropData } { PropertyTable: TPropData }
end; end;
TAttributeProc = function : TCustomAttribute;
PAttributeProcList = ^TAttributeProcList;
TAttributeProcList = array[0..$ffff] of TAttributeProc;
TAttributeData =
{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
packed
{$endif}
record
AttributeCount: word;
AttributesList: TAttributeProcList;
end;
PAttributeData = ^TAttributeData;
PTypeData = ^TTypeData; PTypeData = ^TTypeData;
TTypeData = TTypeData =
{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
@ -623,7 +637,7 @@ unit TypInfo;
ParentInfoRef : TypeInfoPtr; ParentInfoRef : TypeInfoPtr;
PropCount : SmallInt; PropCount : SmallInt;
UnitInfo : PUnitInfo UnitInfo : PUnitInfo
// AttributeData: TAttributeData; // AttributeTable: PAttributeData;
// here the properties follow as array of TPropInfo // here the properties follow as array of TPropInfo
); );
tkRecord: tkRecord:
@ -741,7 +755,7 @@ unit TypInfo;
// 6 : true, constant index property // 6 : true, constant index property
PropProcs : Byte; PropProcs : Byte;
AttributeCount : Byte; AttributeTable : PAttributeData;
Name : ShortString; Name : ShortString;
property PropType: PTypeInfo read GetPropType; property PropType: PTypeInfo read GetPropType;
property Tail: Pointer read GetTail; property Tail: Pointer read GetTail;
@ -750,19 +764,9 @@ unit TypInfo;
TProcInfoProc = Procedure(PropInfo : PPropInfo) of object; TProcInfoProc = Procedure(PropInfo : PPropInfo) of object;
TAttributeProc = function : TCustomAttribute;
PAttributeProcList = ^TAttributeProcList;
TAttributeProcList = array[0..$ffff] of TAttributeProc;
PPropList = ^TPropList; PPropList = ^TPropList;
TPropList = array[0..{$ifdef cpu16}(32768 div sizeof(PPropInfo))-2{$else}65535{$endif}] of PPropInfo; TPropList = array[0..{$ifdef cpu16}(32768 div sizeof(PPropInfo))-2{$else}65535{$endif}] of PPropInfo;
TAttributeData = record
AttributeCount: word;
AttributesList: TAttributeProcList;
end;
PAttributeData = ^TAttributeData;
PUnitInfoList = ^TUnitInfoList; PUnitInfoList = ^TUnitInfoList;
TUnitInfoList = record TUnitInfoList = record
UnitCount: IntPtr; UnitCount: IntPtr;
@ -912,7 +916,6 @@ function GetNextTypeInfo(ATypeInfo: PTypeInfo): PTypeInfo;
function GetAttributeData(TypeInfo: PTypeInfo): PAttributeData; function GetAttributeData(TypeInfo: PTypeInfo): PAttributeData;
function GetPropAttributeProclist(PropInfo: PPropInfo): PAttributeProcList;
function GetPropAttribute(PropInfo: PPropInfo; AttributeNr: byte): TObject; function GetPropAttribute(PropInfo: PPropInfo; AttributeNr: byte): TObject;
function GetAttribute(AttributeData: PAttributeData; AttributeNr: byte): TCustomAttribute; function GetAttribute(AttributeData: PAttributeData; AttributeNr: byte): TCustomAttribute;
@ -1027,7 +1030,7 @@ begin
begin begin
TD := GetTypeData(TypeInfo); TD := GetTypeData(TypeInfo);
if (rmoHasAttributes in td^.UnitInfo^.UnitOptions) then if (rmoHasAttributes in td^.UnitInfo^.UnitOptions) then
Result:=PAttributeData(aligntoptr(pointer(@TD^.UnitInfo)+sizeof(TD^.UnitInfo))) Result:=PAttributeData(PPointer(aligntoptr(pointer(@TD^.UnitInfo)+sizeof(TD^.UnitInfo)))^)
else else
result := nil; result := nil;
end; end;
@ -1035,15 +1038,12 @@ end;
function GetPropData(TypeInfo : PTypeInfo; TypeData: PTypeData) : PPropData; function GetPropData(TypeInfo : PTypeInfo; TypeData: PTypeData) : PPropData;
var var
AD: PAttributeData; p: PtrUInt;
begin begin
p := PtrUInt(@TypeData^.UnitInfo) + SizeOf(TypeData^.UnitInfo);
if rmoHasAttributes in TypeData^.UnitInfo^.UnitOptions then if rmoHasAttributes in TypeData^.UnitInfo^.UnitOptions then
begin p := p + SizeOf(PAttributeData);
AD := GetAttributeData(TypeInfo); Result := PPropData(aligntoptr(Pointer(p)));
result := PPropData(pointer(AD)+SizeOf(AD^.AttributeCount)+(AD^.AttributeCount*SizeOf(TAttributeProc)));
end
else
result := aligntoptr(pointer(@TypeData^.UnitInfo)+sizeof(TypeData^.UnitInfo));
end; end;
function GetFirstTypeinfoFromUnit(AUnitInfo: PUnitInfo): PTypeInfo; function GetFirstTypeinfoFromUnit(AUnitInfo: PUnitInfo): PTypeInfo;
@ -1121,7 +1121,7 @@ begin
pd := GetPropData(ATypeInfo,td); pd := GetPropData(ATypeInfo,td);
p:=@pd^.PropList; p:=@pd^.PropList;
for i:=1 to pd^.PropCount do for i:=1 to pd^.PropCount do
p:=aligntoptr(pointer(@ppropinfo(p)^.Name)+byte(ppropinfo(p)^.Name[0])+(ppropinfo(p)^.AttributeCount*SizeOf(TAttributeProc))+1); p:=aligntoptr(pointer(@ppropinfo(p)^.Name)+byte(ppropinfo(p)^.Name[0]));
end; end;
tkInterface : tkInterface :
begin begin
@ -1150,26 +1150,16 @@ begin
result := nil; result := nil;
end; end;
function GetPropAttributeProclist(PropInfo: PPropInfo): PAttributeProcList;
begin
if PropInfo^.AttributeCount=0 then
result := nil
else
begin
Result:=PAttributeProcList(aligntoptr(pointer(@PropInfo^.Name)+byte(PropInfo^.Name[0])+1));
end;
end;
function GetPropAttribute(PropInfo: PPropInfo; AttributeNr: byte): TObject; function GetPropAttribute(PropInfo: PPropInfo; AttributeNr: byte): TObject;
var var
AttributeProcList: PAttributeProcList; attrtable: PAttributeData;
begin begin
if AttributeNr>=PropInfo^.AttributeCount then attrtable := PropInfo^.AttributeTable;
result := nil if not Assigned(attrtable) or (AttributeNr >= attrtable^.AttributeCount) then
result := Nil
else else
begin begin
AttributeProcList := GetPropAttributeProclist(PropInfo); result := attrtable^.AttributesList[AttributeNr]();
result := AttributeProcList^[AttributeNr]();
end; end;
end; end;
@ -1491,7 +1481,7 @@ begin
if ShortCompareText(Result^.Name, P) = 0 then if ShortCompareText(Result^.Name, P) = 0 then
exit; exit;
// skip to next property // skip to next property
Result:=PPropInfo(aligntoptr(pointer(@Result^.Name)+byte(Result^.Name[0])+(result^.AttributeCount*SizeOf(TAttributeProc))+1)); Result:=PPropInfo(aligntoptr(pointer(@Result^.Name)+byte(Result^.Name[0])+1));
end; end;
// parent class // parent class
Typeinfo:=hp^.ParentInfo; Typeinfo:=hp^.ParentInfo;
@ -1654,7 +1644,7 @@ begin
PropList^[TP^.NameIndex]:=TP; PropList^[TP^.NameIndex]:=TP;
// Point to TP next propinfo record. // Point to TP next propinfo record.
// Located at Name[Length(Name)+1] ! // Located at Name[Length(Name)+1] !
TP:=aligntoptr(PPropInfo(pointer(@TP^.Name)+PByte(@TP^.Name)^+(TP^.AttributeCount*SizeOf(TAttributeProc))+1)); TP:=aligntoptr(PPropInfo(pointer(@TP^.Name)+PByte(@TP^.Name)^+1));
Dec(Count); Dec(Count);
end; end;
TypeInfo:=TD^.Parentinfo; TypeInfo:=TD^.Parentinfo;