fastobj.pas

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

end;

// NewInstanceNoHeaderLargeSize
// For larger sizes
function TObjectAccelerator.NewInstanceNoHeaderLargeSize : TObject;
asm
  push  edi

  push  dword ptr [eax + offset FClass]
  mov   eax, [eax + offset FInstanceSize]
  mov   edi, eax

{$ifdef UseFastMM}
  call  FastGetMem
{$else}
  call  system.@GetMem
{$endif}

  mov   ecx, edi
  mov   edi, eax

{$ifndef ForceMMX}
  {$ifdef EnableMMX}
  cmp   UseMMX, True
  je    @@MMXClear
  {$endif}

  shr   ecx, 2     //count DIV 4 dwords
  mov   edx, eax
  xor   eax, eax

  rep   stosd

  mov   eax, edx
  pop   dword ptr [eax]
  pop   edi
  ret   
{$endif}

{$ifdef EnableMMX}
@@MMXClear:
  add   edi, ecx      //edi point to end of NewInstance
  sub   ecx, SizePtr  //exclude the class pointer
  xor   edx, edx

  {$ifndef Delphi6_Up}
  db    $0F, $6E, $C2
  {$else}
  movd  mm0, edx
  {$endif}

  neg   ecx
  add   ecx, 32
  jnle  @@MMXClearDWords
  
@@MMXClear32Loop:
  {$ifndef Delphi6_Up}
  db    $0F, $7F, $44, $39, $E0
  db    $0F, $7F, $44, $39, $E8
  db    $0F, $7F, $44, $39, $F0
  db    $0F, $7F, $44, $39, $F8
  {$else}
  movq  [edi + ecx - 32], mm0
  movq  [edi + ecx - 24], mm0
  movq  [edi + ecx - 16], mm0
  movq  [edi + ecx - 8], mm0
  {$endif}
  add   ecx, 32
  jle   @@MMXClear32Loop

@@MMXClearDWords:
  jmp   dword ptr [@@MMXClearJumpTable + ecx]
  nop
  nop
  nop
@@MMXClearJumpTable:
  dd    @@MMXClear32
  dd    @@MMXClear28
  dd    @@MMXClear24
  dd    @@MMXClear20
  dd    @@MMXClear16
  dd    @@MMXClear12
  dd    @@MMXClear8
  dd    @@MMXClear4
  dd    @@MMXClear0

@@MMXClear28:
  mov   [edi + ecx - 8], edx
@@MMXClear24:
  {$ifndef Delphi6_Up}
  db    $0F, $7F, $44, $39, $E0
  db    $0F, $7F, $44, $39, $E8
  db    $0F, $7F, $44, $39, $F0
  {$else}
  movq  [edi + ecx - 32], mm0
  movq  [edi + ecx - 24], mm0
  movq  [edi + ecx - 16], mm0
  {$endif}
  jmp   @@MMXClearDone
  nop
  nop
@@MMXClear20:
  mov   [edi + ecx - 16], edx
@@MMXClear16:
  {$ifndef Delphi6_Up}
  db    $0F, $7F, $44, $39, $E0
  db    $0F, $7F, $44, $39, $E8
  {$else}
  movq  [edi + ecx - 32], mm0
  movq  [edi + ecx - 24], mm0
  {$endif}
  jmp   @@MMXClearDone
@@MMXClear12:
  mov   [edi + ecx - 24], edx
@@MMXClear8:
  {$ifndef Delphi6_Up}
  db    $0F, $7F, $44, $39, $E0
  {$else}
  movq  [edi + ecx - 32], mm0
  {$endif}
  jmp   @@MMXClearDone
  nop
@@MMXClear4:
  mov   [edi + ecx - 32], edx
@@MMXClear32:
@@MMXClear0:
@@MMXClearDone:
  {Exit mmx state}
  {$ifndef Delphi6_Up}
  db    $0F, $77
  {$else}
  emms
  {$endif}
{$endif}
  pop   dword ptr [eax]
  pop   edi
end;

// NewInstanceNoField
//
function TObjectAccelerator.NewInstanceNoField : TObject;
asm
   push  dword ptr [eax + offset FClass]

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

   pop   dword ptr [eax]
end;

//BuildFreeInstanceSmallRecord
//builds a dynamic code for faster cleanup
(*
function TObjectAccelerator.BuildFreeInstanceSmallRecord: Pointer;
var
  Buffer : PByteArray;
  L      : cardinal;
  procedure StoreBytes(const Bytes: array of byte);
  var
    S : integer;
  begin
    S := Length(Bytes);
    move(Bytes[0], Buffer[L], S);
    Inc(L, S);
  end;
  procedure StoreByteAndDWord(const AByte: byte; const ADWord: DWord);
  begin
    StoreBytes([AByte]);
    StoreBytes(LongRec(ADWord).Bytes);
  end;
var
  I, N : integer;
begin
  N := 3 + (-2) + FFinalizeCnt * (2 + 5 + 5 + 5 + 5) + 3 + 5;
  //GC: not valid anymore!!
  {$message warn 'solve this'}
  //Result := nil;
  Result := Allocator.GetBlock(N);
  Buffer := Result;
  L := 0;
  StoreBytes([$53, //push ebx
    $89,$C3]);     //mov ebx, eax
  for I := 0 to FFinalizeCnt - 1 do
  begin
    //mov eax, ebx
    if I > 0 then StoreBytes([$89,$D8]);
    //add eax, offset
    StoreByteAndDWord($05, FFinalizeArray[I].Offset_);
    //mov edx, typeinfo
    StoreByteAndDWord($BA, dword(FFinalizeArray[I].TypeInfo));
    //mov ecx, 1
    StoreByteAndDWord($B9, 1);
    //call FinalizeArray
    StoreByteAndDWord($E8, DWord(AddrFinalizeArray) - (DWord(Result) + L + 5));
  end;

  StoreBytes([
    $89,$D8,      //mov eax, ebx
    $5B           //pop ebx
  ]);
  //jmp freemem
  StoreByteAndDWord($E9, DWord(AddrFreeMem) - (DWord(Result) + L + 5));
end;
*)

// FreeInstanceNoRecord
//
procedure TObjectAccelerator.FreeInstanceNoRecord(AObject: TObject);
asm
  mov  eax, edx
{$ifdef UseFastMM}
  jmp  FastFreeMem
{$else}
  jmp  system.@FreeMem
{$endif}
end;

// FreeInstanceOptimized
//
procedure TObjectAccelerator.FreeInstanceOptimized(AObject: TObject);
{$ifdef purepascal}
var
  I   : integer;
  Adr : Pointer;
  TI  : Pointer;
begin
  for I := 0 to FFinalizeCnt - 1 do
  begin
    Cardinal(Adr) := Cardinal(AObject)+FFinalizeArray[I].Offset;
    TI            := FFinalizeArray[I].TypeInfo;
    asm
      mov eax, Adr
      mov edx, TI
      mov ecx, 1
      call system.@FinalizeArray
    end;
  end;
  FreeMem(Pointer(AObject));
{$else}
asm
  push edi
  push esi
  push ebx
  mov  ebx, [eax + offset FFinalizeCnt]
  mov  edi, edx
  mov  esi, [eax + offset FFinalizeArray]

@loop:
  mov  eax, TFieldInfo[esi].Offset_
  add  eax, edi
  mov  edx, TFieldInfo[esi].TypeInfo
  mov  ecx, 1
  call system.@FinalizeArray
  //GC: I don't see any real speed improvment
  //call fastsys.FinalizeSingleElementArray
  add  esi, TYPE TFieldInfo  //SizeOf(TFieldInfo)
  dec  ebx
  jnz  @loop

  mov  eax, edi
  pop  ebx
  pop  esi
  pop  edi

{$ifdef UseFastMM}
  jmp  FastFreeMem
{$else}
  jmp  system.@FreeMem
{$endif}
{$endif}
end;

// CleanupList
//
procedure CleanupList;
var
  I : integer;
begin
  EnterCriticalSection(vAcceleratorCS);
  for I := 0 to vAccelerators.Count - 1 do
  begin
    TObject(vAccelerators[I]).Free;
  end;
  vAccelerators.Free;
  LeaveCriticalSection(vAcceleratorCS);
end;

procedure CreateOptimizer(const AClass: TClass);
type
  TCheckAlign = record
    X : byte;
    Y : dword;
  end;
var
  NewObj : TObjectAccelerator;
begin
  if not vTObjectNewInstanceFlag then begin
{$ifndef ForceRoundInstanceSize}
  {$ifdef Delphi6_Up}
  {$if SizeOf(TCheckAlign) mod 4 <> 0 }
    {$message warn 'It seems that alignment is < 4. FastObj might not process some classes. Define "ForceRoundInstanceSize" to force it.'}
  {$ifend}
  {$endif}
    if AClass.InstanceSize mod 4 <> 0 then exit;
{$endif ForceRoundInstanceSize}
    EnterCriticalSection(vAcceleratorCS);
    vTObjectNewInstanceFlag:=True;
    NewObj := TObjectAccelerator.Create(AClass);
    //this means the class was rejected for any reason
    if NewObj.FClass = nil then
         NewObj.Free
    else vAccelerators.Add(NewObj);
{$ifdef FastObjDebug}
    AddDebugText('Optimize class: '+AClass.ClassName);
{$endif}
    vTObjectNewInstanceFlag:=False;
    LeaveCriticalSection(vAcceleratorCS);
  end;
end;

procedure OptimizeClass(const AClass: TClass);
var
  Addr : Pointer;
  I : integer;
begin
  Addr := GetActualAddress(GetVMTPointer(AClass, VmtOffsetNewInstance));
  for I := 0 to High(NewInstanceList) do
    if Addr = NewInstanceList[I] then exit;

  CreateOptimizer(AClass);
end;

// TObjectNewInstanceTrap
// This trap replaces TObject's NewInstance
//
function TObjectNewInstanceTrap(AClass: TClass): TObject;
{$ifdef SafeAutoOptimize}
var
  AdrNewInstance : Pointer;
{$endif}
begin
//Duplicate TObject.NewInstance behavior
{$ifdef UseFastMM}
  Result := AClass.InitInstance(FastGetMem(AClass.InstanceSize));
{$else}
  GetMem(Pointer(Result), AClass.InstanceSize);
  AClass.InitInstance(Result);
{$endif}

{$ifdef SafeAutoOptimize}
  AdrNewInstance := GetActualAddress(GetVMTPointer(AClass,VmtOffsetNewInstance));
  if (AdrNewInstance <> AddrTObjectNewInstanceTrap)
    and (AdrNewInstance <> AddrTObjectNewInstance)
    and (AdrNewInstance <> AddrTInterfacedObjectNewInstance)
  {$ifdef SafeNamesAutoOptimize}
    and (SafeClassList.IndexOf(AClass.ClassName) < 0)
  {$endif}
    then
    begin
 {$ifdef FastObjDebug}
      AddDebugText('Skip class: '+AClass.ClassName);
 {$endif}
      exit;
    end;
{$endif}
  CreateOptimizer(AClass);
end;

procedure ModuleUnload(Instance: Cardinal);
var
  Obj: TObjectAccelerator;
  I : integer;
begin
  if (Instance = 0) or (Instance = HInstance) then exit;

  EnterCriticalSection(vAcceleratorCS);
  try
    for I := 0 to vAccelerators.Count - 1 do
    begin
      Obj := vAccelerators[I];
      if FindHInstance(Obj.FClass) = HMODULE(Instance) then
      begin
        Obj.CleanDestroy;
        vAccelerators[I] := nil;
      end;
    end;
  finally
    vAccelerators.Pack;
    LeaveCriticalSection(vAcceleratorCS);
  end;
end;

procedure InitAutoOptimize;
begin
  if vTObjectNewInstanceJumpBackup.Jump = 0 then
    SetJump(AddrTObjectNewInstance, AddrTObjectNewInstanceTrap, vTObjectNewInstanceJumpBackup);
end;

// ------------------------------------------------------------------
// ------------------------------------------------------------------
// ------------------------------------------------------------------
initialization
// ------------------------------------------------------------------
// ------------------------------------------------------------------
// ------------------------------------------------------------------
  
  InitializeCriticalSection(vAcceleratorCS);

  Allocator := THeapAllocator.Create(true);

  vAccelerators := TList.Create;

  {$IFNDEF Delphi6_Up}
   VmtOffsetNewInstance := vmtNewInstance;
   VmtOffsetFreeInstance := vmtFreeInstance;
  {$ENDIF Delphi6_Up}
//prepare some constants
  asm
    {$IFDEF Delphi6_Up}
    mov [VmtOffsetNewInstance],  VMTOFFSET TObject.NewInstance
    mov [VmtOffsetFreeInstance], VMTOFFSET TObject.FreeInstance
    {$ENDIF Delphi6_Up}
    lea eax,                     system.@FinalizeArray
    mov [AddrFinalizeArray],     eax
{$ifdef UseFastMM}
    lea  eax,                    fastmm4.FastFreeMem
{$else}
    lea  eax,                    system.@FreeMem
{$endif}
    mov  [AddrFreeMem],          eax
  end;

  AddrFinalizeArray := GetActualAddress(AddrFinalizeArray);
  AddrFreeMem       := GetActualAddress(AddrFreeMem);
  AddrTObjectNewInstance  := GetActualAddress(@TObject.NewInstance);
  AddrTObjectFreeInstance := GetActualAddress(@TObject.FreeInstance);

  NeedRegisterModuleUnload := AddrTObjectNewInstance <> @TObject.NewInstance;

{$ifdef EnableMMX}
{$ifndef ForceMMX}
  UseMMX := IsMMXSupported;
{$endif}
{$endif}
  
  AddrTObjectNewInstanceTrap := @TObjectNewInstanceTrap;

 {$ifdef SafeAutoOptimize}
  AddrTInterfacedObjectNewInstance := GetActualAddress(@TInterfacedObject.NewInstance);
 {$endif}
 {$ifdef SafeNamesAutoOptimize}
  SafeClassList       := TStringList.Create;
  SafeClassList.Sorted := true;
  //SafeClassList.CaseSensitive := false;
  //add all safe classes here:
  //we add them by name, because we don't want to use units
  //this will not work for their descendants
  SafeClassList.Add('TInvokableClass');
  SafeClassList.Add('TRIO');
  SafeClassList.Add('TSoapDataModule');
  SafeClassList.Add('TSOAPDOMProcessor');
  SafeClassList.Add('THTTPReqResp');
  SafeClassList.Add('TXMLDocument');
 {$endif}

  vTObjectNewInstanceJumpBackup.Jump := 0;
{$ifdef AutoOptimize}
  InitAutoOptimize;
{$endif}

  if NeedRegisterModuleUnload then
    AddModuleUnloadProc(ModuleUnload);

finalization
  if vTObjectNewInstanceJumpBackup.Jump <> 0 then
    WriteJumpBuffer(AddrTObjectNewInstance, vTObjectNewInstanceJumpBackup);
 {$ifdef SafeNamesAutoOptimize}
  SafeClassList.Free;
 {$endif}

  if NeedRegisterModuleUnload then
    RemoveModuleUnloadProc(ModuleUnload);

  CleanupList;
  
  DeleteCriticalSection(vAcceleratorCS);

  Allocator.Free;
end.