fastobj.pas

Delphi fastoj-fastsys-patchlib. Use these libs to make delphi faster.

unit FastObj;
(*
//Gabriel Corneanu (gabrielcorneanu(AT)gmail.com)
//General purpose object create/destroy optimization

   Gabriel Corneanu
      - added SafeAutoOptimize mode; read comments
      - added InitAutoOptimize function, can be called from outside
        (instead of define AutoOptimize)
      - Simplified list handling
      - avoid FreeInstance override when reimplemented in a class; it's a sign
        for a special case!
      - solved instance size not multiple of 4 problem
      - much simplified exe block allocation
      - some MMX code (from fastcode), suggested by JiYuan Xie and much simplified
        (no FPU - I measured it much slower)
      - NewInstanceCopyLargeSizeWithFill optimized and rounded clear part
      - Store only template header (if header much smaller than template size)
      - distinguish between newinstance and freeinstance redirection
      - added cleanup optimitation: build a concatenated list of fields for
        all parent classes
        it should be noticeable for classes with several parents,
        containing dynamic fields on several levels (classes)
        and for classes with no dynamic fields
      - changed TObjectNewInstanceTrap to standalone; part of another class
        might be missleading
      - moved patching utilities and dynamic code allocator to standalone unit
      - added several init strategies
      - renamed unit to FastObj and the main class to TObjectAccelerator
        there is no explicit pooling anymore in this version 
      - created allocator for dynamic code
      - created option to disable global optimization
        use OptimizeClass instead to optimize individual classes
      - switch for version independent (no direct calls to FastMM)
      - fixed memory leaks
      - removed class name from offset asm statements, to avoid trouble when
        renaming the class
   Eric Grange (egrange at glscene.org)
      - reengineered around faster InitInstance sequence
      - automatic creation/registration of TClassPool instances
      - should be thread-safe
   JiYuan Xie (gdxjy at hotmail.com)
      - moved all conditional defines to FastObj.inc
      - added Delphi5 support (not tested)
      - added support for being used in package or dll whith sharing classes,
        TExecBlockAllocator has been modified to support this

   TODO:
      - more efficient CleanupInstance
      - think if BuildFreeInstanceSmallRecord makes sense
      - LOTS of testing :)


Cautions:
  FastObj CAN NOT coexist (in AutoOptimize mode) with any class with custom logic
  in NewInstance, which is doing anything else but initializing. FastObj will create
  identical copies of the first cached instance.
  In some cases (found in a singleton implementation that was using NewInstance logic),
  it can cause completely wrong effects.
  Possible solutions:
  - do not use AutoOptimize mode.
  - avoid using FastObj in such classes by not calling TObject.NewInstance (FreeInstance is safe).
  Instead, duplicate its meaning using these lines:
  GetMem(Pointer(Result), InstanceSize);
  InitInstance(Result);

  The new option is "SafeAutoOptimize", which will optimize only classes that DO NOT
  override NewInstance.
  Some known classes like TInterfacedObject are known to be safe and still optimizeed.

*)

{$Include FastObj.inc}

interface


//optimize a specific class, when global optimization is OFF
//DO NOT add the same class twice
procedure OptimizeClass(const AClass: TClass);

procedure InitAutoOptimize;
// ------------------------------------------------------------------
// ------------------------------------------------------------------
// ------------------------------------------------------------------
implementation
// ------------------------------------------------------------------
// ------------------------------------------------------------------
// ------------------------------------------------------------------

uses
{$ifdef UseFastMM}
  FastMM4,
{$endif}
  classes,
  patchlib,
//  SysUtils,
  typinfo,
  Windows;

type
   PRedirectCode_NoParam = ^TRedirectCode_NoParam;
   TRedirectCode_NoParam = packed record
      moveax     : Byte;     //mov eax, selfobj
      selfobj    : Pointer;
      jmp        : Byte;     //jmp offset(new address)
      jmpoffset  : Integer;
      jmpref     : byte;     //not used, just for reference
   end;
   PRedirectCode_OneParam = ^TRedirectCode_OneParam;
   TRedirectCode_OneParam = packed record
      movedx_eax : word;    //$89$C2 mov edx, eax: the old self is passed as param
      Redir      : TRedirectCode_NoParam;
   end;
//compile time check for code alignment
{$ifdef Delphi6_Up}
{$if SizeOf(TRedirectCode_OneParam) > 16}
  {$message fatal 'Check record declaration!'}
{$ifend}
{$endif}

//I wanted to use constants with only one ifdef UseFastMM
//but constant assignment doesn't work
//a variable would create another redirection level
{
type
  TGetMem  = function(Size: Integer): Pointer;
  TFreeMem = function(P: Pointer): Integer;
const
  DoGetMem : TGetMem  = GetMem;
  DoFreeMem: TFreeMem = system.FreeMem;
}

//from system.pas
type
  TFieldInfo = packed record
    TypeInfo : PTypeInfo;
    Offset_  : Cardinal;
  end;

  PFieldTable = ^TFieldTable;
  TFieldTable = packed record
    X: Word;
    Size: Cardinal;
    Count: Cardinal;
    Fields: array [0..0] of TFieldInfo;
  end;

  PFieldInfoArray = ^TFieldInfoArray;
  TFieldInfoArray = array[0..0] of TFieldInfo;

const
  SizePtr  = SizeOf(Pointer);

var
  Allocator : THeapAllocator = nil;
  NeedRegisterModuleUnload : Boolean = false;

type
  // TObjectAccelerator
  //
  TObjectAccelerator = class(TObject)
  private
    FClass             : TClass;
    FClassNewInstance  : Pointer;
    FClassFreeInstance : Pointer;
    FInstanceSize      : Integer;
    FHeaderDWords      : Integer;
    FTemplate          : Pointer;
    FFinalizeArray     : PFieldInfoArray;
    FFinalizeCnt       : cardinal;

    procedure InitRedirect_New(ALocation: PRedirectCode_NoParam; NewMethod: Pointer);
    procedure InitRedirect_Free(ALocation: PRedirectCode_OneParam; NewMethod: Pointer);
    procedure CleanupTemplate;

    function  NewInstanceCopySmall : TObject;
    function  NewInstanceCopyLargeSizeWithFill: TObject;
    function  NewInstanceCopyLargeSizeNoFill: TObject;

    function  NewInstanceNoHeader : TObject;
    function  NewInstanceNoHeaderLargeSize : TObject;
    function  NewInstanceNoField : TObject;

    procedure FreeInstanceOptimized(AObject: TObject);
    procedure FreeInstanceNoRecord(AObject: TObject);
    //function  BuildFreeInstanceSmallRecord: Pointer;
  public
    constructor Create(const AClass: TClass);
    destructor  Destroy; override;
    procedure   CleanDestroy;
  end;

const
  NewInstanceList : array[0..5] of pointer = (
    @TObjectAccelerator.NewInstanceCopySmall,
    @TObjectAccelerator.NewInstanceCopyLargeSizeWithFill,
    @TObjectAccelerator.NewInstanceCopyLargeSizeNoFill,

    @TObjectAccelerator.NewInstanceNoHeader,
    @TObjectAccelerator.NewInstanceNoHeaderLargeSize,
    @TObjectAccelerator.NewInstanceNoField
  );


var
  VmtOffsetNewInstance : Integer;
  VmtOffsetFreeInstance : Integer;

  AddrFinalizeArray : Pointer;
  AddrFreeMem       : Pointer;
  AddrTObjectNewInstance : Pointer;
  AddrTObjectFreeInstance : Pointer;

var
  vAccelerators: TList;
  vAcceleratorCS : TRTLCriticalSection;
  vTObjectNewInstanceFlag : Boolean = False;

  vTObjectNewInstanceJumpBackup : TPatchSimpleJump;
  AddrTObjectNewInstanceTrap : Pointer;
 {$ifdef SafeAutoOptimize}
  AddrTInterfacedObjectNewInstance : Pointer;
 {$endif}
 {$ifdef SafeNamesAutoOptimize}
  SafeClassList       : TStringList;
 {$endif}

 {$ifdef EnableMMX}
  {$ifndef ForceMMX}
  UseMMX: Boolean = false;
  {$endif}
{$endif}


const
{$ifdef EnableMMX}
  cSmallInstanceSize = 24;
{$else}
  cSmallInstanceSize = 32;
{$endif}

{$ifdef FastObjDebug}
procedure AddDebugText(const ALine: string);
var
  S : TStream;
begin
  S := TFileStream.Create(
    CreateFile(PChar(ParamStr(0) + '.fastobj'),
      GENERIC_WRITE, FILE_SHARE_READ, nil, OPEN_ALWAYS, 0, 0));
  S.Seek(0, soEnd);
  S.Write(ALine[1], Length(ALine));
  S.Write(sLineBreak[1], Length(sLineBreak));
  S.Free;
end;
{$endif}

//TypeInfo is dereferenced! to avoid extra operation
procedure BuildFinalizeInfoArray(const AClass: TClass;
                             var AnArray: PFieldInfoArray;
                             var AnArrayLength: Cardinal);
var
  FT: PFieldTable;
  typeinfo : pointer;
  I, S : integer;
  N : cardinal;
  LoopClass : TClass;
begin
  AnArray := nil;
  AnArrayLength := 0;
  N := 0;
  for S := 1 to 2 do
  begin
    LoopClass := AClass;
    if S = 2 then
    begin
      GetMem(AnArray, N * SizeOf(AnArray[0]));
    end;
    while LoopClass <> nil do
    begin
      typeinfo := PPointer(Integer(LoopClass) + vmtInitTable)^;
      if typeinfo <> nil then
      begin
        FT := PFieldTable(Integer(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0]));
        //first step just count, second step build
        if S = 1 then
          Inc(N, FT.Count)
        else
        begin
          for I := 0 to FT.Count - 1 do
          begin
            AnArray[AnArrayLength] := FT.Fields[I];
            //dereference now!
            AnArray[AnArrayLength].TypeInfo := PPointer(AnArray[AnArrayLength].TypeInfo)^;
            Inc(AnArrayLength);
          end;
        end;
      end;
      LoopClass := LoopClass.ClassParent;
    end;
  end;
end;

{ TObjectAccelerator }
// Create
//
constructor TObjectAccelerator.Create(const AClass: TClass);
var
  i : Integer;
  HdrFld : PInteger;
  NewInstanceRedirect  : Pointer;
  FreeInstanceRedirect : Pointer;
begin
   FClass     := AClass;
   //we always need multiple of 4!
   //if this is not valid, it is rejected in CreateOptimizer
   FInstanceSize  := patchlib.RoundInt(FClass.InstanceSize, 4, true);

   // get vmt entries!
   // keep them to be able to restore
   FClassNewInstance  := GetActualAddress(GetVMTPointer(FClass, VmtOffsetNewInstance));
   FClassFreeInstance := GetActualAddress(GetVMTPointer(FClass, VmtOffsetFreeInstance));
   //NewInstanceRedirect  := nil;
   FreeInstanceRedirect := nil;

   //gc: usually NewInstance has some interface related tricks
   //it is safe as long as the result is constant, and NewInstance is reentrant

   // get template
   FTemplate      := FClass.NewInstance;
   // analyse template
   FHeaderDWORDs := 0;
   HdrFld       := FTemplate;
   for i := 0 to (FInstanceSize div SizePtr) -1 do
   begin
     if HdrFld^ <> 0 then FHeaderDWORDs:=i+1;
     Inc(HdrFld);
   end;

   //always cleanup, because we just keep the data!
   TObject(FTemplate).CleanupInstance;

   //initialize the dynamic code here
   NewInstanceRedirect  := Allocator.GetBlock(SizeOf(TRedirectCode_NoParam));
     
   // prepare dynamic code
   // different strategies
   if FHeaderDWORDs > 1 then
   begin
     I := FHeaderDWords * SizePtr;
     if (FInstanceSize >= cSmallInstanceSize) then
     begin
       //GC: important
       //make fill part multiple of 32, to simplify and gain speed in fill instructions
       I := FInstanceSize - RoundInt(FInstanceSize - I, 32, false);
       FHeaderDWords := I div SizePtr;
       if I > 0 then
            InitRedirect_New(NewInstanceRedirect,  @TObjectAccelerator.NewInstanceCopyLargeSizeWithFill)
       else InitRedirect_New(NewInstanceRedirect,  @TObjectAccelerator.NewInstanceCopyLargeSizeNoFill);
       //if difference is significant (to be defined), keep only necessary information from the template
       if FInstanceSize - I > 64 then
         ReallocMem(FTemplate, I);
     end
     else
       InitRedirect_New(NewInstanceRedirect,  @TObjectAccelerator.NewInstanceCopySmall);
   end
   else begin
     CleanupTemplate;
     if FInstanceSize > SizePtr then
     begin
       if FInstanceSize >= cSmallInstanceSize then
          InitRedirect_New(NewInstanceRedirect,  @TObjectAccelerator.NewInstanceNoHeaderLargeSize)
       else InitRedirect_New(NewInstanceRedirect,  @TObjectAccelerator.NewInstanceNoHeader)
     end
     else InitRedirect_New(NewInstanceRedirect,  @TObjectAccelerator.NewInstanceNoField);
   end;

   //GC: do NOT override FreeInstance when it's reimplemented!
   //it's sign of a tricky class
   if FClassFreeInstance <> AddrTObjectFreeInstance then
     FClassFreeInstance := nil
   else
   begin
     BuildFinalizeInfoArray(FClass, FFinalizeArray, FFinalizeCnt);
     {
       GC:
       BuildFreeInstanceSmallRecord is building a simple dynamic asm code
       I don't know if it makes sense, and plus we need variable size allocator
     }
     {
     if (FFinalizeCnt > 0) and (FFinalizeCnt <= 2) then
       FreeInstanceRedirect := BuildFreeInstanceSmallRecord
     else
     }
     begin
       FreeInstanceRedirect := Allocator.GetBlock(SizeOf(TRedirectCode_OneParam));
       if FFinalizeCnt > 0 then
         InitRedirect_Free(FreeInstanceRedirect, @TObjectAccelerator.FreeInstanceOptimized)
       else InitRedirect_Free(FreeInstanceRedirect, @TObjectAccelerator.FreeInstanceNoRecord);
     end;
   end;

   // rewrite vmt entries
   if NewInstanceRedirect <> nil then
     SetVMTPointer(FClass, VmtOffsetNewInstance,   NewInstanceRedirect);
   if FreeInstanceRedirect <> nil then
     SetVMTPointer(FClass, VmtOffsetFreeInstance,  FreeInstanceRedirect);

   if (NewInstanceRedirect = nil) and (FreeInstanceRedirect = nil) then
     FClass := nil;
end;

// Destroy
//
destructor TObjectAccelerator.Destroy;
begin
   // restore vmt entries
   if FClass <> nil then
   begin
     SetVMTPointer(FClass, VmtOffsetNewInstance,   FClassNewInstance);
     SetVMTPointer(FClass, VmtOffsetFreeInstance,  FClassFreeInstance);
   end;
   FreeMem(FFinalizeArray);
   CleanupTemplate;
end;

procedure TObjectAccelerator.CleanDestroy;
var
  RedirectBlock : Pointer;
begin
  if NeedRegisterModuleUnload then
  begin
    RedirectBlock := GetVMTPointer(FClass, VmtOffsetNewInstance);
    if (RedirectBlock <> FClassNewInstance) then
       Allocator.FreeBlock(RedirectBlock);
    RedirectBlock := GetVMTPointer(FClass, VmtOffsetFreeInstance);
    if (RedirectBlock <> FClassFreeInstance) then
       Allocator.FreeBlock(RedirectBlock);
  end;
  Destroy;
end;

// InitRedirect
//
procedure TObjectAccelerator.InitRedirect_New(ALocation: PRedirectCode_NoParam; NewMethod: Pointer);
begin
   with ALocation^ do begin
      moveax     := $B8;   //move eax, self
      selfobj    := self;  //self is our object
      jmp        := $E9;   //jump call
      jmpoffset  := Integer(NewMethod) - Integer(@ALocation.jmpref);
   end;
end;

procedure TObjectAccelerator.InitRedirect_Free(ALocation: PRedirectCode_OneParam; NewMethod: Pointer);
begin
  InitRedirect_New(@ALocation.Redir, NewMethod);
  ALocation.movedx_eax := $C289; //$89$C2 mov edx, eax: the old self is passed as param
end;

// CleanupTemplate
//
procedure TObjectAccelerator.CleanupTemplate;
begin
   if FTemplate<>nil then begin
      FreeMem(FTemplate);
      FTemplate := nil;
   end;
end;

// NewInstanceCopySmall
//
function TObjectAccelerator.NewInstanceCopySmall: TObject;
//   Result:=TObject(FastGetMem(FInstanceSize));
//   Move(Pointer(FTemplate)^, Pointer(Result)^, FInstanceSize);
asm
   push  ebx
   mov   ebx, eax

   mov   eax, [eax + offset FInstanceSize]
{$ifdef UseFastMM}
   call  FastGetMem
{$else}
   call  system.@GetMem
{$endif}

   mov   ecx, [ebx + offset FInstanceSize]
   mov   ebx, [ebx + offset FTemplate]

@@CopyLoop:
   //shorter code
   sub   ecx, SizePtr
   mov   edx, [ebx+ecx]
   mov   [eax+ecx], edx
   jnz   @@CopyLoop

   pop   ebx