absmemory.pas

Absolute Database 是来替代BDE[Borland数据库引擎]的用于Delphi 和 C++ Builder 开发用的数据库引擎. 它小巧, 高速, 健壮, 易于使用. 它能直接编译进

unit ABSMemory;

{$I ABSVer.inc}
{DEFINE USEDELPHIMM}

interface

uses SysUtils, Classes, windows,
     ABSExcept, ABSConst;

type

 TABSMemorySize = Int64; // 5.06

////////////////////////////////////////////////////////////////////////////////
//
// TABSMemoryManager
//
////////////////////////////////////////////////////////////////////////////////

 TABSMemoryManager = class (TObject)
  private
   FMaxMemorySize:        TABSMemorySize;  // Max Memory Limit
   FTotalMemAllocated:    TABSMemorySize;  // Total allocated memory
   FFreeSystemMemorySize: TABSMemorySize;  // Free Memory size in system

   FAllocMemCallCount:    Int64;  // count of allocmem calls
   FGetMemCallCount:      Int64;  // count of getmem calls
   FFreeMemCallCount:     Int64;  // count of freemem calls
   FReallocMemCallCount:  Int64;  // count of reallocmem calls

   MMLock: TRTLCriticalSection;
  public
   // Constructor
   constructor Create; overload;
   // Constructor
   constructor Create(MaxMemorySize: TABSMemorySize); overload;
   // Destructor
   destructor Destroy; override;
   // GetMem analog
   function GetMem(BufferSize: TABSMemorySize): Pointer;
   // AllocMem analog
   function AllocMem(BufferSize: TABSMemorySize): Pointer;
   // ReAllocMem analog
   procedure ReallocMem(var Buffer; BufferSize: TABSMemorySize; ClearTail: Boolean = False);
   // ReAllocMem and clear Tail of Buffer
   procedure ReallocMemAndClearTail(var Buffer; BufferSize: TABSMemorySize);
   // FreeMem and set pointer to nil
   procedure FreeAndNillMem(var Buffer);
   // FreeMem
   procedure FreeMem(const Buffer: Pointer);
   // Return buffer size
   function GetMemoryBufferSize(Buffer: Pointer): TABSMemorySize;
   // Get min from free system memory size and (FMaxMemorySize - FTotalMemAllocated)
   function GetFreeMemorySize:  TABSMemorySize;
  public
   property MaxMemorySize:        TABSMemorySize read FMaxMemorySize;
   property TotalMemAllocated:    TABSMemorySize read FTotalMemAllocated;
   // statistics usage
   property AllocMemCallCount:    Int64 read FAllocMemCallCount;
   property GetMemCallCount:      Int64 read FGetMemCallCount;
   property FreeMemCallCount:     Int64 read FFreeMemCallCount;
   property ReallocMemCallCount:  Int64 read FReallocMemCallCount;
 end; // TABSMemoryManager

// Memory Manager variable
var MemoryManager: TABSMemoryManager = nil;

// move memory block
procedure ABSMove(const Source; var Dest; count : Integer );

implementation

uses Math;


type
  TGetMemType = (gmtGetMem, gmtVirtualAlloc, gmtGlobalAlloc);

  // Memory Block Header
  PABSMemoryBlockHeader = ^TABSMemoryBlockHeader;
  TABSMemoryBlockHeader = packed record
    Size: Integer;
    GetMemType: TGetMemType;
    Signature: Cardinal;  // Last 4 byte
  end;

  // Memory Block Footer
  PABSMemoryBlockFooter = ^TABSMemoryBlockFooter;
  TABSMemoryBlockFooter = packed record
    Signature: Cardinal;  // = ABSMemoryEndSignature
  end;


const  ABSMemorySignature:    Cardinal = $ACCACCAC;
       ABSMemoryEndSignature: Cardinal = $ACCEACCE;

type
   TGetMemFunction = packed record
     Size: Integer;
     GetMemType: TGetMemType;
   end;

const

// If Enable MemChecker then use only GetMem function
{$IFDEF DEBUG_MEMCHECK}
   GetMemTypes: array[1..1] of TGetMemFunction =
      (
        (Size: MaxInt;  GetMemType: gmtGetMem)
      );
{$ELSE}
   GetMemTypes: array[1..4] of TGetMemFunction =
      (
        (Size: 726;   GetMemType: gmtGetMem),          // 0     - 1024  ==> GetMem
        (Size: 64500;  GetMemType: gmtGlobalAlloc),    // 1025  - 64500 ==> GlobalAlloc
        (Size: 1048576;  GetMemType: gmtGetMem),       // 64500 - 1 MB ...  ==> GetMem
        (Size: MaxInt;  GetMemType: gmtGlobalAlloc)    // 1 MB -  ...  ==> GlobalAlloc
      );
{$ENDIF}

function GetMemFunctionType(MemSize: Integer): TGetMemType;
var i: Integer;
begin
  // Set GetMem Function for Maximum Size 
  Result := GetMemTypes[High(GetMemTypes)].GetMemType;
  // Find lower diapason
  for i:= High(GetMemTypes) downto Low(GetMemTypes)  do
    if (MemSize <= GetMemTypes[i].Size) then
     begin
      Result := GetMemTypes[i].GetMemType;
      Break;
     end;
end;

////////////////////////////////////////////////////////////////////////////////
//
// TABSMemoryManager
//
////////////////////////////////////////////////////////////////////////////////


//------------------------------------------------------------------------------
// Constructor
//------------------------------------------------------------------------------
constructor TABSMemoryManager.Create;
begin
 FMaxMemorySize := 0;
 InitializeCriticalSection(MMLock);
end;//Create

//------------------------------------------------------------------------------
// Constructor
//------------------------------------------------------------------------------
constructor TABSMemoryManager.Create(MaxMemorySize: TABSMemorySize);
begin
 Create;
 FMaxMemorySize := MaxMemorySize;
end;//Create


//------------------------------------------------------------------------------
// Destructor
//------------------------------------------------------------------------------
destructor TABSMemoryManager.Destroy;
begin
 DeleteCriticalSection(MMLock);
{$IFNDEF DEBUG_MEMCHECK}
 {$IFDEF DEBUG_MEMLEAKS}
 if FTotalMemAllocated <> 0 then
   raise EABSException.Create(30003, ErrorGMemoryLeakFound, [FTotalMemAllocated]);
 {$ENDIF}
{$ENDIF}
end;//Destructor


//------------------------------------------------------------------------------
// GetMemoryBufferSize
//------------------------------------------------------------------------------
function TABSMemoryManager.GetMemoryBufferSize(Buffer: Pointer): TABSMemorySize;
var
  Block: PABSMemoryBlockHeader;
begin
  {$IFDEF USEDELPHIMM}
  Result := 0;
  Exit;
  {$ENDIF}
  if Buffer = nil then
    Result := 0
  else
    begin
  Block := PABSMemoryBlockHeader(PChar(Buffer) - SizeOf(TABSMemoryBlockHeader));
  if (Block.Signature = ABSMemorySignature) then
    Result := Block.Size
  else
    raise EABSException.Create(30005, ErrorGInvalidPointer);
    end;
end;
//GetMemoryBufferSize


//------------------------------------------------------------------------------
// GetMem
//------------------------------------------------------------------------------
function TABSMemoryManager.GetMem(BufferSize: TABSMemorySize): Pointer;
var
  NewSize: TABSMemorySize;
  BlockHeader: PABSMemoryBlockHeader;
  BlockFooter: PABSMemoryBlockFooter;
  GetMemType: TGetMemType;
begin
  {$IFDEF USEDELPHIMM}
  System.GetMem(Result, BufferSize);
  Exit;
  {$ENDIF}
  // Increment Counter
  {$IFDEF MEMDEBUG}
  Inc(FGetMemCallCount);
  {$ENDIF}

  // Allocate 0 bytes ?
  if (BufferSize = 0) then
    raise EABSException.Create(30286, ErrorGCannotAllocateZeroBytes);

  // Mem Limit ?
  if ((FMaxMemorySize <> 0) and
      (BufferSize + FTotalMemAllocated > FMaxMemorySize)) then
    raise EABSException.Create(30004, ErrorGMemoryLimitExceeded, [FMaxMemorySize]);

  try
    // Calculate New Size of Buffer
    NewSize := BufferSize + SizeOf(TABSMemoryBlockHeader) + SizeOf(TABSMemoryBlockFooter);

    // GetMem
    GetMemType := GetMemFunctionType(NewSize);
    case GetMemType of
      gmtGetMem:
          System.GetMem(BlockHeader, NewSize);
      gmtVirtualAlloc:
          BlockHeader := VirtualAlloc(nil, NewSize, MEM_COMMIT, PAGE_READWRITE);
      gmtGlobalAlloc:
          BlockHeader := Pointer(GlobalAlloc(GMEM_FIXED, NewSize))
      else
          raise EABSException.Create(30340, ErrorGUnknownGetMemType, [Integer(GetMemType)]);
    end;
    // Fill Block Header
    BlockHeader.GetMemType := GetMemType;
    BlockHeader.Signature := ABSMemorySignature;
    BlockHeader.Size := BufferSize;
    // Fill Block Footer
    BlockFooter := Pointer(PChar(BlockHeader) + SizeOf(TABSMemoryBlockHeader) + BufferSize);
    BlockFooter.Signature := ABSMemoryEndSignature;


    Result := Pointer(Cardinal(BlockHeader) + SizeOf(TABSMemoryBlockHeader));
    EnterCriticalSection(MMLock);
    Inc(FTotalMemAllocated, BufferSize);
    LeaveCriticalSection(MMLock);
  except
    on e: Exception do
      raise EABSException.Create(30015, ErrorGGetMemError, [e.Message]);
  end;
end;//GetMem


//------------------------------------------------------------------------------
// AllocMem
//------------------------------------------------------------------------------
function TABSMemoryManager.AllocMem(BufferSize:TABSMemorySize):Pointer;
begin
  {$IFDEF USEDELPHIMM}
  Result := Sysutils.AllocMem(BufferSize);
  Exit;
  {$ENDIF}

  {$IFDEF MEMDEBUG}
  Inc(FAllocMemCallCount);
  {$ENDIF}
  try
    Result := self.GetMem(BufferSize);
    FillChar(Result^, BufferSize, 0);
  finally
    //Dec(FGetMemCallCount);
  end;
end;//AllocMem


//------------------------------------------------------------------------------
// FreeMem and set Pointer to nil
//------------------------------------------------------------------------------
procedure TABSMemoryManager.FreeAndNillMem(var Buffer);
var
  BlockHeader: PABSMemoryBlockHeader;
  BlockFooter: PABSMemoryBlockFooter;
  FooterIncorrect: Boolean;
begin
  {$IFDEF USEDELPHIMM}
  System.FreeMemory(Pointer(Buffer));
  Pointer(Buffer) := nil;
  Exit;
  {$ENDIF}

  // Increment Counter
  {$IFDEF MEMDEBUG}
  Inc(FFreeMemCallCount);
  {$ENDIF}  
  try
    // Check Header Signature
    BlockHeader := PABSMemoryBlockHeader(PChar(Buffer) - SizeOf(TABSMemoryBlockHeader));
    if (BlockHeader.Signature <> ABSMemorySignature) then
      raise EABSException.Create(30001, ErrorGInvalidPointer);

    // Check Footer Signature
    BlockFooter := Pointer(PChar(Buffer) + BlockHeader.Size);
    FooterIncorrect := (BlockFooter.Signature <> ABSMemoryEndSignature);

    // Calculate TotalMemAllocated
    EnterCriticalSection(MMLock);
    Dec(FTotalMemAllocated, BlockHeader.Size);
    LeaveCriticalSection(MMLock);

    // FreeMem
    case BlockHeader.GetMemType of
      gmtGetMem:
          System.FreeMem(BlockHeader);
      gmtVirtualAlloc:
          VirtualFree(BlockHeader, 0, MEM_RELEASE);
      gmtGlobalAlloc:
          GlobalFree(Cardinal(Pointer(BlockHeader)));
    end;

    // Clear Buffer Pointer
    Pointer(Buffer) := nil;

    // if Footer Signature incorrect then raise
    if (FooterIncorrect) then
      raise EABSException.Create(30137, ErrorGMemoryOverrunDetected);

  except
    on EABSException do raise;
    on e: Exception do
      raise EABSException.Create(30138, ErrorGFreeMemError, [e.Message]);
  end;
end;//FreeAndNillMem


//------------------------------------------------------------------------------
// FreeMem
//------------------------------------------------------------------------------
procedure TABSMemoryManager.FreeMem(const Buffer: Pointer);
var Buffer1: Pointer;
begin
  Buffer1 := Buffer;
  FreeAndNillMem(Buffer1);
end;// FreeMem


//------------------------------------------------------------------------------
// ReallocMem
//------------------------------------------------------------------------------
procedure TABSMemoryManager.ReallocMem(var Buffer; BufferSize: TABSMemorySize; ClearTail: Boolean);
var
  BlockHeader: PABSMemoryBlockHeader;
  NewBuffer: Pointer;
begin
  {$IFDEF USEDELPHIMM}
  System.ReallocMem(Pointer(Buffer), BufferSize);
  Exit;
  {$ENDIF}
  // Increment Counter
  {$IFDEF MEMDEBUG}
  Inc(FReallocMemCallCount);
  {$ENDIF}
  try
    // Check Header Signature
    BlockHeader := PABSMemoryBlockHeader(PChar(Buffer) - SizeOf(TABSMemoryBlockHeader));
    if (BlockHeader.Signature <> ABSMemorySignature) then
      raise EABSException.Create(30002, ErrorGInvalidPointer);

    // GetMem
    NewBuffer := Self.GetMem(BufferSize);
    // Copy OldBuffer to NewBuffer
    Move(PChar(Buffer)^, NewBuffer^,
       min(BufferSize, BlockHeader.Size));
    // Clear Tail
    if (ClearTail) then
      if (BufferSize > BlockHeader.Size) then
        FillChar(PChar(PChar(NewBuffer) + BlockHeader.Size)^, BufferSize-BlockHeader.Size, 0);

    // Free old buffer
    Self.FreeAndNillMem(PChar(Buffer));
    // Set Buffer to NewBuffer
    Pointer(Buffer) := NewBuffer;

    // Correct call counters
    {$IFDEF MEMDEBUG}
    Dec(FGetMemCallCount);
    Dec(FFreeMemCallCount);
    {$ENDIF}
  except
    on e: Exception do
      raise EABSException.Create(30014, ErrorGReallocMemError, [e.Message]);
  end;
end;//ReallocMem


//------------------------------------------------------------------------------
// ReAllocMem and clear Tail of Buffer
//------------------------------------------------------------------------------
procedure TABSMemoryManager.ReallocMemAndClearTail(var Buffer; BufferSize: TABSMemorySize);
begin
  ReallocMem(Buffer, BufferSize, True);
end;//ReallocMemAndClearTail


//------------------------------------------------------------------------------
// GetFreeMemorySize
//------------------------------------------------------------------------------
function TABSMemoryManager.GetFreeMemorySize: TABSMemorySize;
var
  Status: TMemoryStatus;
begin
  GlobalMemoryStatus(Status);
  FFreeSystemMemorySize := Status.dwAvailPhys;
  if (FMaxMemorySize = 0) then
    Result := FFreeSystemMemorySize
  else
    Result := Min(FFreeSystemMemorySize, FMaxMemorySize);
end;//GetFreeMemorySize


//------------------------------------------------------------------------------
// move memory block
//------------------------------------------------------------------------------
procedure ABSMove(const Source; var Dest; Count : Integer );
var
  S, D: PChar;
  I, Offset: Integer;
begin
  S := PChar(@Source);
  D := PChar(@Dest);
  Offset := D - S;
  if ((Offset > 0) and (Offset < 4)) then
    for i := Count-1 downto 0 do
      (D+i)^ := (S+i)^
  else
  if ((Offset > -4) and (Offset < 0)) then
    for i := 0 to Count-1 do
      (D+i)^ := (S+i)^
  else
    Move(Source, Dest, Count);
end;


initialization

 MemoryManager := TABSMemoryManager.Create;

finalization

 MemoryManager.Free;
 MemoryManager := nil;

end.