bigbrainpro.pas

内存管理程序

//    function smb_GetSizeIndexSize(self: PSuperMemBlock): integer;
    function smb_GetUserDataArea(self: PSuperMemBlock): pointer;{$IFNDEF NOINLINE}inline;{$ENDIF}
    function smb_GetHeaderSize(self: PSuperMemBlock): integer;{$IFNDEF NOINLINE}inline;{$ENDIF}
    function smb_GetUserAreaSize(self: PSuperMemBlock): integer;
    function smb_GetWasteBytes(self: PSuperMemBlock): integer;{$IFNDEF NOINLINE}inline;{$ENDIF}
    function smb_GetAvailable(self: PSuperMemBlock): boolean;{$IFNDEF NOINLINE}inline;{$ENDIF}

//    property Available:boolean read GetAvailable write SetAvailable;
//    property NextBlock: pointer read FNextBlock write SetNextBlock;
//    property PreviousBlock: pointer read FPreviousBlock  write SetPreviousBlock;
//    property IsLinked: boolean read GetisLinked;

type


  THeapObject=class
  public
    class function NewInstance:TObject; override;
    procedure FreeInstance; override;
  end;

  TBlockManager = class;

  TlockedBlockList = class;

  PLockedBlockList = {$IFNDEF USELISTCLASS}^{$ENDIF}TLockedBlockList;

  TLockedBlockList = {$IFDEF USELISTCLASS}class(THeapObject){$ELSE}object{$ENDIF}
  private
    FWasteBytes: integer;
    FBlockCount: integer;
    FUsedBytes: integer;
    FFreeBytes: integer;
    sect: TCLXCriticalSection;
    tip: PSuperMemBlock;
    FFreePool: boolean;
    Fowner: TBlockManager;
    FAllocTo: TLockedBlockList;
    FFreeTo: TLockedBlockList;

    function Extract: PSuperMemBlock;
    procedure TallyStats(block: PSuperMemBlock);
    procedure UnTallyStats(block: PSuperMemBlock);
    function GEtFreeBytes: integer;{$IFNDEF NOINLINE}inline;{$ENDIF}
    function GetAllocBytes: integer;{$IFNDEF NOINLINE}inline;{$ENDIF}
    function GEtBlockCount: integer;{$IFNDEF NOINLINE}inline;{$ENDIF}
    function GetUsedBytes: integer;{$IFNDEF NOINLINE}inline;{$ENDIF}
    function GetWasteBytes: integer;{$IFNDEF NOINLINE}inline;{$ENDIF}
  public

    {$IFDEF USELISTCLASS}
    constructor Create(Aowner: pointer); reintroduce; virtual;
    destructor Destroy; override;
    {$ENDIF}
    procedure Lock;{$IFNDEF NOINLINE}inline;{$ENDIF}
    procedure Unlock;{$IFNDEF NOINLINE}inline;{$ENDIF}

    procedure Link(block: PSuperMemBlock);{$IFNDEF NOINLINE}inline;{$ENDIF}
    procedure Unlink(block: PSuperMemBlock);{$IFNDEF NOINLINE}inline;{$ENDIF}
    procedure LockedUnlink(block: PSuperMemBlock);{$IFNDEF NOINLINE}inline;{$ENDIF}
    function LockedExtract: PSuperMemBlock;{$IFNDEF NOINLINE}inline;{$ENDIF}
    procedure LockedLInk(block: PSuperMemBlock);{$IFNDEF NOINLINE}inline;{$ENDIF}

    property FreeBytes: integer read GEtFreeBytes;
    property AllocBytes: integer read GetAllocBytes;
    property BlockCount: integer read GEtBlockCount;
    property UsedBytes: integer read GetUsedBytes;
    property WasteBytes: integer read GetWasteBytes;

    property FreePool: boolean read FFreePool write FFreePool;

    procedure Init(AOwner: TBlockManager);{$IFNDEF NOINLINE}inline;{$ENDIF}
    procedure Finalize;{$IFNDEF NOINLINE}inline;{$ENDIF}
    property Owner: TBlockMAnager read FOwner;
    property AllocTo: TLockedBlockList read FallocTo write FAllocTo;
    property FreeTo: TLockedBlocklist read FFreeTo write FFreeTo;
  end;


  //PLockedBlockList = {$IFNDEF USELISTCLASS}^{$ENDIF}TLockedBlockList;

  TBlockManager=class(THeapObject)
  private
    function GetFree: boolean;{$IFNDEF NOINLINE}inline;{$ENDIF}
    function GetAllocBytes: integer;{$IFNDEF NOINLINE}inline;{$ENDIF}
    function GetBlockCount: integer;{$IFNDEF NOINLINE}inline;{$ENDIF}
    function GetFreeBytes: integer;{$IFNDEF NOINLINE}inline;{$ENDIF}
    function GetUsedBytes: integer;{$IFNDEF NOINLINE}inline;{$ENDIF}
    function GetWasteBytes: integer;{$IFNDEF NOINLINE}inline;{$ENDIF}
  protected
    //!Free flags/variables
    FFree: boolean;
    FFreeTime: cardinal;
    FFreeing: boolean;

    Fblocks: array[0..MAXBIT] of TLockedBlockList;
    FFreeBlocks: array[0..MAXBIT] of TLockedBlockList;
    FDestroyCountdown: integer;

    sect: TCLXCriticalSection;

    //!Statistics


    //!Key Block Management functions
    function ResizeBlock(block: pSuperMEmBlock;
      Size: integer): PSuperMemBlock;{$IFNDEF NOINLINE}inline;{$ENDIF}
    function NeedBlock(UserSize: integer): PSuperMemBlock;{$IFNDEF NOINLINE}inline;{$ENDIF}
    procedure PrefetchExtraBlock(UserSize: integer);{$IFNDEF NOINLINE}inline;{$ENDIF}
    procedure NoNeedBlock(block: pSuperMemBlock);{$IFNDEF NOINLINE}inline;{$ENDIF}

    //!Key Block Management functions for talking to OS
    function AllocateNewBlock(UserSize: integer): PSuperMemBlock; virtual;
    procedure FreeBlockToOS(block:PSuperMemBlock); {$IFNDEF NOINLINE}inline;{$ENDIF}

    //!Key Link list management functions
    procedure LinkAllocated(block: PSuperMemBlock);{$IFNDEF NOINLINE}inline;{$ENDIF}
    procedure UnlinkAllocated(block: PSuperMemBlock);{$IFNDEF NOINLINE}inline;{$ENDIF}
    procedure LinkFreed(block: PSuperMemBlock);{$IFNDEF NOINLINE}inline;{$ENDIF}
    procedure  UnlinkFreed(block: PSuperMemBlock);{$IFNDEF NOINLINE}inline;{$ENDIF}

    //!Debug
    function CheckAlloc: boolean;{$IFNDEF NOINLINE}inline;{$ENDIF}
    function CheckFree: boolean;{$IFNDEF NOINLINE}inline;{$ENDIF}

    //!Construction
    procedure InitBlocks;{$IFNDEF NOINLINE}inline;{$ENDIF}
    procedure FinalizeBlocks;{$IFNDEF NOINLINE}inline;{$ENDIF}

    //!Getters/Setters
    function GEtBlockHeaderOverhead: integer;{$IFNDEF NOINLINE}inline;{$ENDIF}
//    function GetFreeBlockCount(idx: integer): integer;
//    function GetRealWasteBytes: integer;
    procedure SetFree(const Value: boolean);{$IFNDEF NOINLINE}inline;{$ENDIF}
    function GetDestroyCount: integer;

  public
    //create/destroy
    constructor Create; reintroduce; virtual;
    destructor Destroy; override;


    //!Newmem, FreeMem, Reallocmem handlers
    function ResizeMemory(p: pointer; Size: integer): pointer;virtual;
    function NeedMemory(UserSize: integer): pointer;virtual;
    procedure NoNeedMemory(p: pointer);virtual;

    //!Managers talking to other managers
    function ExtractBlock(UserSize: integer): PSuperMemBlock;{$IFNDEF NOINLINE}inline;{$ENDIF}
    procedure InjectBlock(block: PSuperMemBlock);{$IFNDEF NOINLINE}inline;{$ENDIF}
    procedure RemanageBlock(block: PSuperMemBlock);{$IFNDEF NOINLINE}inline;{$ENDIF}

    //!Instrumentation/Statistics

    property BlockHeaderOverhead: integer read GEtBlockHeaderOverhead;

    //!Flags
    property Freeing: boolean read FFreeing write FFreeing;
    property IsFree: boolean read GetFree write SetFree;
    property DestroyCount: integer read GetDestroycount;
    procedure DestroyCountdown;
    property FreeTime: cardinal read FFreeTime;

    //!Locks
    function TryLock: boolean;{$IFNDEF NOINLINE}inline;{$ENDIF}
    procedure Lock;{$IFNDEF NOINLINE}inline;{$ENDIF}
    Procedure Unlock;{$IFNDEF NOINLINE}inline;{$ENDIF}

    //!Garbage collection
    procedure Clean; virtual;

    //!debug
    function CheckMem: boolean;{$IFNDEF NOINLINE}inline;{$ENDIF}
//    property RealWasteBytes: integer read GetRealWasteBytes;
//    property FreeBlockCount[idx: integer]: integer read GetFreeBlockCount;

    property FreeBytes: integer read GetFreeBytes;
    property AllocBytes: integer read GetAllocBytes;
    property BlockCount: integer read GetBlockCount;
    property UsedBytes: integer read GetUsedBytes;
    property WasteBytes: integer read GetWasteBytes;



  end;

  TThreadBlockManager = class(TBlockManager)
  //Manager for a specific thread
  private
    FMainMan: TBlockManager;
  public
    //!Construction/destruction
    constructor Create;override;
    destructor Destroy;override;

    //!New Properties/Methods
    procedure EmptyBlocksToMain;{$IFNDEF NOINLINE}inline;{$ENDIF}
    property MainMan: TBlockManager read FMainMan write FMainMan;

    //!Overrides
    function AllocateNewBlock(Size: integer): PSuperMemBlock; override;
    procedure NoNeedBlock(block: pSuperMemBlock);{$IFNDEF NOINLINE}inline;{$ENDIF}
    procedure Clean; override;

  end;

  TBlockManagerManager=class(THeapObject)
  //Manages block managers
  private
    list: array [0..30000] of TBlockManager;
//    reserve: array[0..30000] of TBlockManager;
    sect: TCLXCriticalSection;
    Fcount: integer;
    Fdanger: integer;

    //!Getters/setters
    function GetBlockManager(idx: integer): TBlockManager;{$IFNDEF NOINLINE}inline;{$ENDIF}
    function GetManagerCount: integer;{$IFNDEF NOINLINE}inline;{$ENDIF}


  public
    //!Construction/destruction
    constructor create;reintroduce; virtual;
    destructor Destroy; override;

    //!Managers
    property Managers[idx: integer]: TBlockManager read GetBlockManager;
    property ManagerCount: integer read GetManagerCount;
    function NewManager: TThreadBlockManager;{$IFNDEF NOINLINE}inline;{$ENDIF}
    procedure FreeManager(man: TBlockManager);{$IFNDEF NOINLINE}inline;{$ENDIF}
    procedure RegisterManager(bm: TBlockManager);{$IFNDEF NOINLINE}inline;{$ENDIF}
    procedure DeregisterManager(bm: TblockManager);{$IFNDEF NOINLINE}inline;{$ENDIF}
    function IndexOf(bm: TblockManager): integer;{$IFNDEF NOINLINE}inline;{$ENDIF}
    procedure AddMan(bm: TBlockManager);{$IFNDEF NOINLINE}inline;{$ENDIF}
    procedure DeleteMan(idx: integer);{$IFNDEF NOINLINE}inline;{$ENDIF}

    //!Danger zone
    procedure EnterDangerZone;{$IFNDEF NOINLINE}inline;{$ENDIF}
    procedure LeaveDangerZone;{$IFNDEF NOINLINE}inline;{$ENDIF}

    //!Locks
    procedure Lock;{$IFNDEF NOINLINE}inline;{$ENDIF}
    procedure Unlock;{$IFNDEF NOINLINE}inline;{$ENDIF}
    function TryLock: boolean;{$IFNDEF NOINLINE}inline;{$ENDIF}

    //!Garbage collection
    procedure Clean;{$IFNDEF NOINLINE}inline;{$ENDIF}

    //!Experimental
    function LockFirstAvailable: TThreadBlockManager;{$IFNDEF NOINLINE}inline;{$ENDIF}

    function TotalBlockCount: integer;{$IFNDEF NOINLINE}inline;{$ENDIF}
    function TotalFreeBytes: integer;{$IFNDEF NOINLINE}inline;{$ENDIF}
    function TotalBytes: integer;{$IFNDEF NOINLINE}inline;{$ENDIF}

  end;




//!This is crazy stuff for hooking into when a thread ends
type
  PJump=^TJump;
  TJump=packed record
    OpCode:byte;
    Distance:integer;
  end;

var
  OldCode:TJump;
  NewCode:TJump=(OpCode:$E9; Distance:0);
  FHeap: integer;
  FHeaps: array[0..31] of integer;
  FHeapLocks: array[0..31] of TCLXCriticalSection;

//var
//  SingleCPU: boolean;

procedure NewEndThread(exitCode:integer); register;

//!Helper functions
//!*****************************************************************************
//!Binary Search
function HighOrderBit(Value:integer):integer;
function LowOrderBit(Value:integer):integer;

//!Size conversion
function InflateSize(Size: integer): integer;{$IFNDEF NOINLINE}inline;{$ENDIF}
function GetSizeIndexSize(BlockSize: integer): integer;{$IFNDEF NOINLINE}inline;{$ENDIF}
function GetsizeIndex(BlockSize: integer): integer;{$IFNDEF NOINLINE}inline;{$ENDIF}

//!Other
procedure MoveMem32(D,S:Pointer;Size:integer);//!!
function LesserOf(i1, i2: integer): integer;{$IFNDEF NOINLINE}inline;{$ENDIF}

//!Primary memory manager replacement functions
function NewGetMem(Size: integer): pointer;
function NewFreeMem(p: pointer): integer;
function NewReallocMem(p: pointer; Size: integer): pointer;
function LiteGetMem(Size: integer): pointer;
function LiteFreeMem(p: pointer): integer;
function LiteReallocMem(p: pointer; Size: integer): pointer;



var
  OldMan: TMemoryManager;
  NewMan: TMemoryManager;
  MainMan: TBlockManager;
  ManMan: TBlockManagerManager;

threadvar
  ThreadMemMan: TBlockManager;



implementation

function LesserOf(i1, i2: integer): integer;
begin
  if i1 < i2 then
    result := i1
  else
    result := i2;
end;

{ THeapObject }

procedure THeapObject.FreeInstance;
begin
  OldMan.FreeMem(self);
end;

class function THeapObject.NewInstance: TObject;
begin
  Result:=InitInstance(OldMan.GetMem(InstanceSize));
end;

function HighOrderBit(Value:integer):integer;
asm
  bsr edx,eax  // find high order bit
  mov eax,edx
end;

function LowOrderBit(Value:integer):integer;
asm
  bsf edx,eax  // find low order bit
  mov eax,edx
end;


{ TBlockManager }


function TBlockManager.AllocateNewBlock(UserSize: integer): PSuperMemBlock;
var
  iHEaderSize: integer;
  iNEwSize: integer;
begin
  //increment the size to include enough room for header
  iHeaderSize := SizeOf(TSuperMemBlock);

  //allocate memory from OS
  iNewSize := UserSize+iHeaderSize;
  iNewSize := GetSizeIndexSize(iNEwSize);
  {$IFNDEF USELITEASOS}
  result := oldMan.GetMem(iNewSize);
//  result := HeapAlloc(FHeap, 0 , iNewSize);
  {$ELSE}
  result := LiteGetMem(iNewSize);
  {$ENDIF}


  //Initialize the result
  smb_Init(result, UserSize);

  //Add the block to one of the lists
//  LinkAllocated(result);
  //CheckMem;

end;

function TBlockManager.CheckAlloc: boolean;
begin
  result := true;
end;

function TBlockManager.CheckFree: boolean;
begin
  result := true;
end;

function TBlockManager.CheckMem: boolean;
begin
//  result := true;
//  exit;
  Lock;
  try
    result := CheckAlloc and CheckFree;
  finally
    Unlock;
  end;
end;



constructor TBlockManager.Create;
begin
  inherited;

  FFree := false;
  FFreeTime := 0;


  InitializeCRiticalSection(sect);
  InitBlocks;

end;


destructor TBlockManager.Destroy;
begin
  self.FinalizeBlocks;
  DeleteCriticalSEction(sect);
  inherited;
end;

function TBlockManager.ExtractBlock(UserSize: integer): PSuperMemBlock;
var
  freeBlock: PSuperMemBlock;
  iSizeIndex: integer;
begin
  Lock;
{$IFDEF EXTRA_ERR_CHECKING}try{$ENDIF}
    iSizeIndex := GetSizeIndex(InflateSize(UserSize));
    freeblock := FFreeBlocks[iSizeIndex].LockedExtract;

    if freeblock = nil then begin
      freeBlock := AllocateNewBlock(UserSize);
    end;

    //CheckMem;

    result := freeBlock;
{$IFDEF EXTRA_ERR_CHECKING}finally{$ENDIF}
    Unlock;
{$IFDEF EXTRA_ERR_CHECKING}end;{$ENDIF}


end;

procedure TBlockManager.FreeBlockToOS(block: PSuperMemBlock);
begin

  {$IFNDEF USELITEASOS}
  oldman.FreeMem(block);
//  BigBrainPro.HeapFree(FHeap, 0, block);
  {$ELSE}
  LiteFreeMem(block);
  {$ENDIF}

//  result := HeapAlloc(FHeap, 0 , iNewSize);
end;


function TBlockManager.GEtBlockHeaderOverhead: integer;
begin
  result := BlockCount*(SizeOf(TSuperMemBlock));
end;