paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-07-08 23:45:54 +02:00
Code Issues Packages Projects Releases Wiki Activity

JitClasses: Add ability to have "per class" user memory. Allocates mem in front of the VMT for the user code to store arbitrary data.

Browse Source
This commit is contained in:
Martin 2021-11-25 20:59:32 +01:00
parent c3a2bf802b
commit df1cac999f
1 changed files with 117 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

152
components/jitclasses/jitclass.pas
View File

@ -23,6 +23,7 @@ unit JitClass;
{$mode objfpc}{$H+} {$mode objfpc}{$H+}
{$ModeSwitch typehelpers} {$ModeSwitch typehelpers}
{$ModeSwitch advancedrecords}
{$PointerMath on} {$PointerMath on}
{.$Inline off} {.$Inline off}
@ -189,20 +190,38 @@ type
TJitClassCreator = class(TJitClassCreatorBase) TJitClassCreator = class(TJitClassCreatorBase)
private type private type
{ TVmtMem }
TVmtMem = record
strict private
FExtraHeadSize: Integer; // Bytes allocated before the the actual typeinfo
private
FMemVmtPtr: PVmt;
function GetHeadPtr: Pointer;
public
function Allocate(ASize: Integer; AExtraHeadSize: Integer = 0): Pointer;
procedure DeAllocate;
procedure ClearMemPointer; // does not free
property HeadPtr: Pointer read GetHeadPtr;
property VmtPtr: PVmt read FMemVmtPtr;
property ExtraHeadSize: Integer read FExtraHeadSize;
end;
{ TRefCountedJitClassReference } { TRefCountedJitClassReference }
TRefCountedJitClassReference = class(TRefCountedJitNestedReference) TRefCountedJitClassReference = class(TRefCountedJitNestedReference)
private private
FJitPVmt: PVmt; FJitPVmtMem: TVmtMem;
FAnchorClassRef: TRefCountedJitReference; FAnchorClassRef: TRefCountedJitReference;
procedure SetJitPVmt(AJitPVmt: PVmt); procedure SetJitPVmt(const AJitPVmtMem: TVmtMem);
procedure FreePVmt; procedure FreePVmt;
property FJitPVmt: PVmt read FJitPVmtMem.FMemVmtPtr;
protected protected
procedure DoRefCountZero; override; procedure DoRefCountZero; override;
function NestedCount: integer; override; function NestedCount: integer; override;
function GetNested(AnIndex: integer): TRefCountedJitReference; override; function GetNested(AnIndex: integer): TRefCountedJitReference; override;
public public
constructor Create(AJitPVmt: PVmt); constructor Create(const AJitPVmtMem: TVmtMem);
procedure AddToList(AJitProp: TJitProperty); procedure AddToList(AJitProp: TJitProperty);
procedure ClearList; override; procedure ClearList; override;
end; end;
@ -213,12 +232,15 @@ type
ccfJitPropsPrepareDone ccfJitPropsPrepareDone
); );
TJitClassCreatorFlags = set of TJitClassCreatorFlag; TJitClassCreatorFlags = set of TJitClassCreatorFlag;
strict private
FJitPVmtMem: TVmtMem;
private private
FJitMethods: TJitMethodList; FJitMethods: TJitMethodList;
FJitProperties: TJitPropertyList; FJitProperties: TJitPropertyList;
FFlags: TJitClassCreatorFlags; FFlags: TJitClassCreatorFlags;
FJitPVmt: PVmt; property FJitPVmt: PVmt read FJitPVmtMem.FMemVmtPtr;
private
FRefCountedJitPVmt: TRefCountedJitClassReference; FRefCountedJitPVmt: TRefCountedJitClassReference;
FAncestorClass: TClass; FAncestorClass: TClass;
FAncestorClassName: String; FAncestorClassName: String;
@ -229,10 +251,12 @@ type
// Set by CreateJitPropsPrepare for CreateJitPropsFinish // Set by CreateJitPropsPrepare for CreateJitPropsFinish
FTypeInfoMemSize, FRedirectPtrMemSize, FVmtParentMemSize: Integer; FTypeInfoMemSize, FRedirectPtrMemSize, FVmtParentMemSize: Integer;
FUserInfoMemSize: Integer;
FRttiWriterClass: TJitRttiWriterTkClass; FRttiWriterClass: TJitRttiWriterTkClass;
function RefCountedJitPvmt: TRefCountedJitClassReference; function RefCountedJitPvmt: TRefCountedJitClassReference;
procedure SetJitPVmt(AJitPVmt: PVmt); procedure AllocateJitPVmt(ASize: Integer);
procedure DeAllocateJitPVmt;
procedure DoTypeLibFreed(Sender: TObject); procedure DoTypeLibFreed(Sender: TObject);
procedure DoAnchesterJitClassFreed(Sender: TObject); procedure DoAnchesterJitClassFreed(Sender: TObject);
@ -242,7 +266,7 @@ type
procedure RaiseUnless(ACond: Boolean; const AMsg: string); procedure RaiseUnless(ACond: Boolean; const AMsg: string);
function dbgsFlag(AFlags: TJitClassCreatorFlags): String; function dbgsFlag(AFlags: TJitClassCreatorFlags): String;
protected protected
class procedure FreeJitClass(AJitPVmt: PVmt); class procedure FreeJitClass(const AJitPVmtMem: TVmtMem);
function GetLockReferenceObj: TRefCountedJitReference; override; function GetLockReferenceObj: TRefCountedJitReference; override;
function GetTypeInfo: PTypeInfo; override; function GetTypeInfo: PTypeInfo; override;
function GetJitClass: TClass; override; function GetJitClass: TClass; override;
@ -258,6 +282,7 @@ type
procedure CreateJitProps; procedure CreateJitProps;
procedure CreateJitPropsPrepare; procedure CreateJitPropsPrepare;
procedure CreateJitPropsFinish; procedure CreateJitPropsFinish;
procedure Init; virtual;
public public
constructor Create(AnAncestorClass: TClass; AClassName: String; AClassUnit: String; ATypeLibrary: TJitTypeLibrary = nil); constructor Create(AnAncestorClass: TClass; AClassName: String; AClassUnit: String; ATypeLibrary: TJitTypeLibrary = nil);
constructor Create(AnAncestorClassName, AClassName: String; AClassUnit: String; ATypeLibrary: TJitTypeLibrary = nil); constructor Create(AnAncestorClassName, AClassName: String; AClassUnit: String; ATypeLibrary: TJitTypeLibrary = nil);
@ -296,6 +321,8 @@ type
property JitClass: TClass read GetJitClass; property JitClass: TClass read GetJitClass;
property AncestorJitClass: TJitClassCreator read FAncestorJitClass; experimental; property AncestorJitClass: TJitClassCreator read FAncestorJitClass; experimental;
property UserInfoMemSize: Integer read FUserInfoMemSize write FUserInfoMemSize; // User must call procedure UpdateJitClass for it to take effect
end; end;
implementation implementation
@ -442,10 +469,39 @@ begin
inherited Destroy; inherited Destroy;
end; end;
{ TJitClassCreator.TVmtMem }
function TJitClassCreator.TVmtMem.GetHeadPtr: Pointer;
begin
Result := Pointer(FMemVmtPtr) - FExtraHeadSize;
end;
function TJitClassCreator.TVmtMem.Allocate(ASize: Integer;
AExtraHeadSize: Integer): Pointer;
begin
assert(FMemVmtPtr=nil, 'TJitClassCreator.TVmtMem.Allocate: FMemVmtPtr=nil');
AExtraHeadSize := align(AExtraHeadSize, sizeof(Pointer));
FExtraHeadSize := AExtraHeadSize;
FMemVmtPtr := AllocMem(ASize + AExtraHeadSize) + AExtraHeadSize;
end;
procedure TJitClassCreator.TVmtMem.DeAllocate;
begin
Freemem(HeadPtr);
FMemVmtPtr := nil;
FExtraHeadSize := 0;
end;
procedure TJitClassCreator.TVmtMem.ClearMemPointer;
begin
FMemVmtPtr := nil;
FExtraHeadSize := 0;
end;
{ TJitClassCreator.TRefCountedJitClassReference } { TJitClassCreator.TRefCountedJitClassReference }
procedure TJitClassCreator.TRefCountedJitClassReference.SetJitPVmt( procedure TJitClassCreator.TRefCountedJitClassReference.SetJitPVmt(
AJitPVmt: PVmt); const AJitPVmtMem: TVmtMem);
begin begin
if (RefCount > 1) and (FJitPVmt <> nil) then if (RefCount > 1) and (FJitPVmt <> nil) then
raise Exception.Create('set TypeInfo while referrenced'); raise Exception.Create('set TypeInfo while referrenced');
@ -455,12 +511,12 @@ begin
FreePVmt; FreePVmt;
end; end;
FJitPVmt := AJitPVmt; FJitPVmtMem := AJitPVmtMem;
end; end;
procedure TJitClassCreator.TRefCountedJitClassReference.FreePVmt; procedure TJitClassCreator.TRefCountedJitClassReference.FreePVmt;
begin begin
TJitClassCreator.FreeJitClass(FJitPVmt); TJitClassCreator.FreeJitClass(FJitPVmtMem);
end; end;
procedure TJitClassCreator.TRefCountedJitClassReference.DoRefCountZero; procedure TJitClassCreator.TRefCountedJitClassReference.DoRefCountZero;
@ -493,11 +549,11 @@ begin
Result := inherited GetNested(AnIndex); Result := inherited GetNested(AnIndex);
end; end;
constructor TJitClassCreator.TRefCountedJitClassReference.Create(AJitPVmt: PVmt constructor TJitClassCreator.TRefCountedJitClassReference.Create(
); const AJitPVmtMem: TVmtMem);
begin begin
inherited Create; inherited Create;
FJitPVmt := AJitPVmt; FJitPVmtMem := AJitPVmtMem;
end; end;
procedure TJitClassCreator.TRefCountedJitClassReference.AddToList( procedure TJitClassCreator.TRefCountedJitClassReference.AddToList(
@ -943,25 +999,42 @@ function TJitClassCreator.RefCountedJitPvmt: TRefCountedJitClassReference;
begin begin
if FRefCountedJitPVmt = nil then begin if FRefCountedJitPVmt = nil then begin
(* FTypeInfo may be nil, but a refernce can be got anyway *) (* FTypeInfo may be nil, but a refernce can be got anyway *)
FRefCountedJitPVmt := TRefCountedJitClassReference.Create(FJitPVmt); FRefCountedJitPVmt := TRefCountedJitClassReference.Create(FJitPVmtMem);
end; end;
Result := FRefCountedJitPVmt; Result := FRefCountedJitPVmt;
end; end;
procedure TJitClassCreator.SetJitPVmt(AJitPVmt: PVmt); procedure TJitClassCreator.AllocateJitPVmt(ASize: Integer);
begin begin
if FJitPVmt = AJitPVmt then Exit; DeAllocateJitPVmt;
FJitPVmt := AJitPVmt; FJitPVmtMem.Allocate(ASize, FUserInfoMemSize);
if FRefCountedJitPVmt <> nil then begin if FRefCountedJitPVmt <> nil then begin
if (FRefCountedJitPVmt.RefCount = 1) or (FRefCountedJitPVmt.FJitPVmt = nil) then if (FRefCountedJitPVmt.RefCount = 1) or (FRefCountedJitPVmt.FJitPVmt = nil) then
FRefCountedJitPVmt.SetJitPVmt(AJitPVmt) FRefCountedJitPVmt.SetJitPVmt(FJitPVmtMem)
else begin else begin
FRefCountedJitPVmt.ReleaseLock; FRefCountedJitPVmt.ReleaseLock;
FRefCountedJitPVmt := TRefCountedJitClassReference.Create(AJitPVmt); FRefCountedJitPVmt := TRefCountedJitClassReference.Create(FJitPVmtMem);
end; end;
end; end;
end; end;
procedure TJitClassCreator.DeAllocateJitPVmt;
begin
if FJitPVmt = nil then
exit;
if (FRefCountedJitPVmt <> nil) and (FRefCountedJitPVmt.RefCount > 1) then begin
FRefCountedJitPVmt.ReleaseLock;
FJitPVmtMem.ClearMemPointer; // memory is kept bi ref
end
else begin
FJitPVmtMem.DeAllocate;
if (FRefCountedJitPVmt <> nil) then
FRefCountedJitPVmt.SetJitPVmt(FJitPVmtMem);
end;
end;
function TJitClassCreator.GetJitClass: TClass; function TJitClassCreator.GetJitClass: TClass;
begin begin
if not assigned(FJitPVmt) then if not assigned(FJitPVmt) then
@ -1064,7 +1137,7 @@ begin
// create vmt // create vmt
VmtFullSize:=GetVMTSize(FAncestorClass); VmtFullSize:=GetVMTSize(FAncestorClass);
VmtMethodsSize:=VmtFullSize-vmtMethodStart; VmtMethodsSize:=VmtFullSize-vmtMethodStart;
SetJitPVmt(AllocMem(VmtFullSize)); AllocateJitPVmt(VmtFullSize);
(* The following entries are searched recursively in the base classes, (* The following entries are searched recursively in the base classes,
and do not need to be copied. and do not need to be copied.
@ -1205,25 +1278,25 @@ begin
CreateJitClassContinueAfteVMT; CreateJitClassContinueAfteVMT;
end; end;
class procedure TJitClassCreator.FreeJitClass(AJitPVmt: PVmt); class procedure TJitClassCreator.FreeJitClass(const AJitPVmtMem: TVmtMem);
begin begin
if AJitPVmt = nil then if AJitPVmtMem.VmtPtr = nil then
exit; exit;
if AJitPVmt^.vTypeInfo <> nil then if AJitPVmtMem.VmtPtr^.vTypeInfo <> nil then
Freemem(AJitPVmt^.vTypeInfo); Freemem(AJitPVmtMem.VmtPtr^.vTypeInfo);
if AJitPVmt^.vInitTable <> nil then if AJitPVmtMem.VmtPtr^.vInitTable <> nil then
Freemem(AJitPVmt^.vInitTable); Freemem(AJitPVmtMem.VmtPtr^.vInitTable);
if AJitPVmt^.vMethodTable <> nil then if AJitPVmtMem.VmtPtr^.vMethodTable <> nil then
Freemem(AJitPVmt^.vMethodTable); Freemem(AJitPVmtMem.VmtPtr^.vMethodTable);
if AJitPVmt^.vClassName <> nil then if AJitPVmtMem.VmtPtr^.vClassName <> nil then
Freemem(AJitPVmt^.vClassName); Freemem(AJitPVmtMem.VmtPtr^.vClassName);
{$IFnDEF HasVMTParent} {$IFnDEF HasVMTParent}
if AJitPVmt^.vParentRef<> nil then if AJitPVmtMem.VmtPtr^.vParentRef<> nil then
Freemem(AJitPVmt^.vParentRef); Freemem(AJitPVmtMem.VmtPtr^.vParentRef);
{$ENDIF} {$ENDIF}
Freemem(AJitPVmt); AJitPVmtMem.DeAllocate;
end; end;
procedure TJitClassCreator.UpdateClassName; procedure TJitClassCreator.UpdateClassName;
@ -1474,6 +1547,11 @@ begin
end; end;
end; end;
procedure TJitClassCreator.Init;
begin
//
end;
function TJitClassCreator.GetTypeInfo: PTypeInfo; function TJitClassCreator.GetTypeInfo: PTypeInfo;
begin begin
GetJitClass; GetJitClass;
@ -1483,7 +1561,7 @@ end;
constructor TJitClassCreator.Create(AnAncestorClass: TClass; constructor TJitClassCreator.Create(AnAncestorClass: TClass;
AClassName: String; AClassUnit: String; ATypeLibrary: TJitTypeLibrary); AClassName: String; AClassUnit: String; ATypeLibrary: TJitTypeLibrary);
begin begin
FJitPVmt := nil; FJitPVmtMem.ClearMemPointer;
FJitMethods := TJitMethodList.Create(Self); FJitMethods := TJitMethodList.Create(Self);
FJitProperties := TJitPropertyList.Create(Self); FJitProperties := TJitPropertyList.Create(Self);
@ -1493,6 +1571,7 @@ begin
FClassName := AClassName; FClassName := AClassName;
FClassUnit := AClassUnit; FClassUnit := AClassUnit;
TypeLibrary := ATypeLibrary; TypeLibrary := ATypeLibrary;
Init;
end; end;
constructor TJitClassCreator.Create(AnAncestorClassName, AClassName: String; constructor TJitClassCreator.Create(AnAncestorClassName, AClassName: String;
@ -1500,6 +1579,7 @@ constructor TJitClassCreator.Create(AnAncestorClassName, AClassName: String;
begin begin
Create(TClass(nil), AClassName, AClassUnit, ATypeLibrary); Create(TClass(nil), AClassName, AClassUnit, ATypeLibrary);
FAncestorClassName := AnAncestorClassName; FAncestorClassName := AnAncestorClassName;
Init;
end; end;
constructor TJitClassCreator.Create(AnAncestorJitClass: TJitClassCreator; constructor TJitClassCreator.Create(AnAncestorJitClass: TJitClassCreator;
@ -1509,6 +1589,7 @@ begin
FAncestorJitClass := AnAncestorJitClass; FAncestorJitClass := AnAncestorJitClass;
if FAncestorJitClass <> nil then if FAncestorJitClass <> nil then
FAncestorJitClass.AddFreeNotification(@DoAnchesterJitClassFreed); FAncestorJitClass.AddFreeNotification(@DoAnchesterJitClassFreed);
Init;
end; end;
constructor TJitClassCreator.Create(AnAncestorJitType: TJitType; constructor TJitClassCreator.Create(AnAncestorJitType: TJitType;
@ -1518,6 +1599,7 @@ begin
raise Exception.Create('Incorrect type for anchestor'); raise Exception.Create('Incorrect type for anchestor');
Create(TClass(nil), AClassName, AClassUnit, ATypeLibrary); Create(TClass(nil), AClassName, AClassUnit, ATypeLibrary);
FAncestorJitType := TJitTypeClassBase(AnAncestorJitType); FAncestorJitType := TJitTypeClassBase(AnAncestorJitType);
Init;
end; end;
destructor TJitClassCreator.Destroy; destructor TJitClassCreator.Destroy;
@ -1526,7 +1608,7 @@ begin
if FRefCountedJitPVmt <> nil then if FRefCountedJitPVmt <> nil then
FRefCountedJitPVmt.ReleaseLock FRefCountedJitPVmt.ReleaseLock
else else
FreeJitClass(FJitPVmt); FreeJitClass(FJitPVmtMem);
if FTypeLibrary <> nil then if FTypeLibrary <> nil then
FTypeLibrary.RemoveFreeNotification(@DoTypeLibFreed); FTypeLibrary.RemoveFreeNotification(@DoTypeLibFreed);
@ -1553,7 +1635,7 @@ end;
procedure TJitClassCreator.RecreateJitClass; procedure TJitClassCreator.RecreateJitClass;
begin begin
FFlags := []; FFlags := [];
SetJitPVmt(nil); DeAllocateJitPVmt;
end; end;
end. end.