在DdelphiXE下也模拟了一个:
//! defines an allocation strategy
TIrrAllocStragegy =
(
iasSafeAllocate,
iasDoubleAllocate,
iasSortAllocate
);
TIrrAllocInit =
(
iaiDefault,
iaiForce,
iaiNone
);
TIrrAllocatorBase = class;
TIrrAllocatorClass = class of TIrrAllocatorBase;
TIrrAllocatorBase = class(TObject)
protected
class var FClassList: TList<TIrrAllocatorClass>;
public
class constructor Create;
class destructor Destroy;
class function FindClass(AClassName: String; var AClass: TIrrAllocatorClass): Boolean;
class function GetClassListCount: Integer;
class function GetClass(const Index: Integer): TIrrAllocatorClass;
class function GetMemNode(Count: Integer = 1;
InitNode: TIrrAllocInit = iaiDefault): Pointer; virtual; abstract;
class procedure FreeMemNode(P: Pointer;
FinalNode: TIrrAllocInit = iaiDefault); virtual; abstract;
end;
TIrrAllocator<T> = class(TIrrAllocatorBase)
protected
class var TypeInfoPtr: Pointer;
class var TypeDataSize: Integer;
class var ManagedFieldCount: Integer;
class var NodeType: TTypeKind;
class var NeedInit: Boolean;
class var AllocatedInfo: TDictionary<Pointer, Integer>;
class var AllocatedCount: Integer;
public
class function GetMemNode(Count: Integer = 1;
InitNode: TIrrAllocInit = iaiDefault): Pointer; override;
class procedure FreeMemNode(P: Pointer;
FinalNode: TIrrAllocInit = iaiDefault); override;
class constructor Create;
class destructor Destroy;
class function GetNodeCount: Integer; inline;
class function GetNodeSize: Integer; inline;
end;
implementation
{ TIrrAllocator }
{ TIrrAllocatorBase }
class constructor TIrrAllocatorBase.Create;
begin
FClassList := TList<TIrrAllocatorClass>.Create;
end;
class destructor TIrrAllocatorBase.Destroy;
begin
FClassList.Free;
end;
class function TIrrAllocatorBase.FindClass(AClassName: String;
var AClass: TIrrAllocatorClass): Boolean;
var
i: Integer;
begin
for i := 0 to FClassList.Count - 1 do
begin
if UpperCase(FClassList.Items[i].ClassName) = UpperCase(AClassName) then
begin
AClass := FClassList.Items[i];
Result := True;
Exit;
end;
end;
Result := False;
end;
class function TIrrAllocatorBase.GetClass(
const Index: Integer): TIrrAllocatorClass;
begin
Result := FClassList.Items[Index];
end;
class function TIrrAllocatorBase.GetClassListCount: Integer;
begin
Result := FClassList.Count;
end;
{ TIrrAllocator<T> }
class constructor TIrrAllocator<T>.Create;
var
TypeDataPtr, NodeTypeDataPtr: PTypeData;
NodeTypePtr: PTypeInfo;
begin
TypeInfoPtr := TypeInfo(TIrrAllocator<T>);
TypeDataSize := SizeOf(T);
NodeTypePtr := typeinfo(T);
if Assigned(NodeTypePtr) then
begin
NodeType := NodeTypePtr^.Kind;
NodeTypeDataPtr := GetTypeData(NodeTypePtr);
if Assigned(NodeTypeDataPtr) then
ManagedFieldCount := NodeTypeDataPtr^.ManagedFldCount;
end;
//proceduce init final function
NeedInit := (ManagedFieldCount > 0) or
(NodeType in
[
tkLString,
tkWString,
tkInterface,
tkDynArray,
tkUString,
tkVariant
//tkArray,
//tkRecord
]
);
if NeedInit then
AllocatedInfo := TDictionary<Pointer, Integer>.Create;
FClassList.Add(TIrrAllocator<T>);
end;
class destructor TIrrAllocator<T>.Destroy;
begin
AllocatedInfo.Free;
end;
class procedure TIrrAllocator<T>.FreeMemNode(P: Pointer;
FinalNode: TIrrAllocInit = iaiDefault);
var
MemCount: Integer;
begin
MemCount := 1;
if Assigned(AllocatedInfo) then
begin
if AllocatedInfo.TryGetValue(P, MemCount) then
begin
AllocatedInfo.Remove(P);
end
else
begin
MemCount := 1;
end;
end;
case FinalNode of
iaiDefault:
begin
if NeedInit then
begin
FinalizeArray(P, typeinfo(T), MemCount);
end;
end;
end;
FreeMem(P);
AllocatedCount := AllocatedCount - MemCount;
end;
class function TIrrAllocator<T>.GetMemNode(Count: Integer;
InitNode: TIrrAllocInit): Pointer;
var
P: Pointer;
MemSize: NativeUInt;
begin
MemSize := TypeDataSize * Count;
GetMem(P, MemSize);
AllocatedCount := AllocatedCount + Count;
case InitNode of
iaiDefault:
if NeedInit then
begin
InitializeArray(P, typeinfo(T), Count);
if Count > 1 then
AllocatedInfo.Add(P, Count);
end;
iaiForce:
begin
if NeedInit then
begin
InitializeArray(P, typeinfo(T), Count);
if Count > 1 then
AllocatedInfo.Add(P, Count);
end
else
begin
FillChar(P^, MemSize, 0);
end;
end;
end;
Result := P;
end;
class function TIrrAllocator<T>.GetNodeCount: Integer;
begin
Result := AllocatedCount;
end;
class function TIrrAllocator<T>.GetNodeSize: Integer;
begin
Result := TypeDataSize;
end;
这样,对于某类数据结构就可以在程序中方便的作数量统计,内存统计.
然而,这里有个问题,对于记录类型等可以完成功能,但无法应用到对象类型.
主要原因是,对象内存分配是通过NewInstance完成的.
因此,我产生了重写NewInstance的想法.
于是,我试图构造另一个泛型类:
TMObject = class(TObject)
class function NewInstance: TObject; override;
procedure FreeInstance; override;
end;
TIrrObjectAllocator<T: TMObject> = class(TIrrAllocatorBase)
end;
希望,需要统计数量以及内存消耗的类型都通过从 TMObject 派生完成.
然而,当我要去重写 TMObject.NewInstance的实现时,陷入了尴尬的境地
class function TMObject.NewInstance: TObject;
begin
Result := TIrrObjectAllocator<ClassType>.GetMemNode;
end;
这是无法通过的.原因是虽然, TObject有ClassType返回类型,但是,那是在运行期.
而不是在编译期.因此,不能编译通过也是正常的.
不知道有没有高手有好的想法.
