bigbrainpro.pas

内存管理程序

  {$IFNDEF LINUX}
  VirtualProtect(EndThreadAddr,5,OldProtect,Protect);
  FlushInstructionCache(GetCurrentProcess, EndThreadAddr,5);
  {$ENDIF}
end;



function TThreadBlockManager.AllocateNewBlock(
  Size: integer): PSuperMemBlock;
begin
  //ask the main manager for a block

  MainMan.Lock;
{$IFDEF EXTRA_ERR_CHECKING}try{$ENDIF}
    result := MAinMan.ExtractBlock(Size);
{$IFDEF EXTRA_ERR_CHECKING}finally{$ENDIF}
    MainMan.Unlock;
{$IFDEF EXTRA_ERR_CHECKING}end;{$ENDIF}

  if result = nil then
    result := inherited AllocateNewBlock(Size);

  //LinkAllocated(result);

end;

procedure TBlockManager.Clean;
var
  t,cx: integer;
  block: PSuperMemBlock;
begin
  Lock;
{$IFDEF EXTRA_ERR_CHECKING}try{$ENDIF}
    cx := 0;
    for t:= MAXBIT downto 0 do begin
      repeat
        block := FFreeBlocks[t].LockedExtract;
        if block<> nil then begin
          self.FreeBlockToOS(block);
        end;
        inc(cx);
      until (block = nil) or (cx > 64);
    end;

    //CheckMem;

{$IFDEF EXTRA_ERR_CHECKING}finally{$ENDIF}
    Unlock;
{$IFDEF EXTRA_ERR_CHECKING}end;{$ENDIF}
end;


procedure TThreadBlockManager.Clean;
var
  t,u: integer;
  block: PSuperMemBlock;
  cx: integer;
begin
  Lock;
  try
    if IsFree then
      cx := 10
    else
      cx := 3;



    for t:= MAXBIT downto 0 do begin
      for u := 0 to cx do begin
        FFreeBlocks[t].Lock;
        try
          block := FFreeBlocks[t].Extract;
          if block<> nil then begin
            //UnlinkFreed(block);
            MainMan.InjectBlock(block);
          end else
            break;
        finally
          FFreeBlocks[t].unlock;
        end;
      end;
    end;

    //CheckMem;

  finally
    Unlock;
  end;
end;
constructor TThreadBlockManager.Create;
begin
  inherited;
  ManMan.RegisterManager(self);
end;

destructor TThreadBlockManager.Destroy;
begin
  ManMan.DeregisterManager(self);
  EmptyBlocksToMain;
  inherited;
end;

procedure TThreadBlockManager.EmptyBlocksToMain;
var
  t: integer;
  block: PSuperMemBlock;
begin
  Lock;
  for t:=0 to 31 do begin


    repeat

      block := FFreeBlocks[t].Extract;
      if block = nil then break;

      //UnLinkFreed(block);
      MainMan.InjectBlock(block);

    until block = nil;
//      sleep(1);
  end;
  UnLock;

  Lock;
  for t:=0 to MAXBIT do begin


    repeat

      block := FBlocks[t].LockedExtract;
      if block = nil then break;

      MainMan.REmanageBlock(block);


    until block = nil;
//    sleep(1);
  end;
  Unlock;


end;

procedure TThreadBlockManager.NoNeedBlock(block: pSuperMemBlock);
begin
  inherited NoNeedBlock(block);

(*  if FFreeBytes > FAllocBytes then begin
    UnlinkFreed(block);
    MainMan.InjectBlock(block);
  end;*)


end;

{ TBlockManagerManager }

procedure TBlockManagerManager.AddMan(bm: TBlockManager);
var
  i: integer;
begin
  i := FCount;
  inc(FCount);
(*  if FCount > length(list) then
    SetLength(list, Fcount+1);)*)


  list[i] := bm;
end;


procedure TBlockManagerManager.Clean;
var
  t: integer;
  man: TBlockManager;
//  tm1, tm2: cardinal;
begin
  {$IFNDEF FREEMAN}exit;{$ENDIF}

  //tm2:= GetTickCount;

  try
    for t:= ManagerCount-1 downto 0 do begin
      man := Managers[t];
      if man.IsFree then begin
        man.Lock;
        try
          //tm1 := man.FreeTime;
          man.Freeing := true;

          TThreadBlockManager(man).EmptyBlocksToMain;

          man.DestroyCountdown;

          if man.DestroyCount > 2 then begin
             man.free;
             man := nil;
          end;

        finally
          if man <> nil then
            man.Unlock;
        end;


(*        //lock no longer needed because blocks should be emptied to main
        //except in the case where a block may have chosen this manager but not yet locked it
        //if threads are in this "danger zone" then exit
        if FDanger > 0 then exit;

        man.Free;*)


        //if (tm2< tm1) or ((tm1+MANAGER_TIMEOUT)<tm2) then begin
      end;
    end;
  finally
  end;



end;

constructor TBlockManagerManager.create;
begin
  inherited;
  InitializeCriticalSection(sect);
  FCount := 0;
//  SetLength(list, 3000);
  FDanger := 0;


end;

procedure TBlockManagerManager.DeleteMan(idx: integer);
var
  t: integer;
  i: integer;
begin
  if idx<0 then exit;

  i := ManagerCount;
  for t:= idx+1 to i-1 do begin
    list[t-1] := list[t];
  end;

  dec(FCount);



end;

procedure TBlockManagerManager.DeregisterManager(bm: TblockManager);
begin
  ManMan.Lock;
  try
    self.DeleteMan(IndexOf(bm));
  finally
    ManMan.Unlock;
  end;
end;

destructor TBlockManagerManager.Destroy;
begin



  DeleteCriticalSection(Sect);
  inherited;

end;

procedure TBlockManagerManager.EnterDangerZone;
begin
//  Lock;
  {$IFDEF FREEMAN}
  InterlockedIncrement(Fdanger);
  {$ENDIF}
end;

procedure TBlockManagerManager.FreeManager(man: TBlockManager);
begin
  man.lock;
  try
    man.IsFree := true;


  finally
    man.unlock;
  end;
end;

function TBlockManagerManager.GetBlockManager(idx: integer): TBlockManager;
begin
  result := list[idx];
end;

function TBlockManagerManager.GetManagerCount: integer;
begin
  result := FCount;
end;

function TBlockManagerManager.IndexOf(bm: TblockManager): integer;
var
  t: integer;
begin
  result := -1;
  for t:= 0 to ManagerCount-1 do begin
    if list[t]=bm then begin
      result :=t;
      break;
    end;
  end;

end;

procedure TBlockManagerManager.LeaveDangerZone;
begin
//  Unlock;
  {$IFDEF FREEMAN}
  InterlockedDecrement(Fdanger);
  {$ENDIF}
end;

procedure TBlockManagerManager.Lock;
begin
  EnterCriticalSection(sect);
end;

function TBlockManagerManager.LockFirstAvailable: TThreadBlockManager;
var
  icount: integer;
  t: integer;
begin
  result := nil;
  while result = nil do begin
    {$IFDEF FREEMAN}Lock;try{$ENDIF}
    iCount := self.FCount;

    for t:= 1 to iCount-1 do
    if self.Managers[t].TryLock then begin
      result := TThreadBlockManager(Managers[t]);
      break;
    end;



    {$IFDEF FREEMAN}finally UnLock; end;{$ENDIF}





  end;

end;

function TBlockManagerManager.NewManager: TThreadBlockManager;
var
  t: integer;
  man : TBlockManager;
begin
  Lock;
  try
    result := nil;
    for t:= 1 to managercount-1 do begin
      man := Managers[t];
      man.Lock;
      try
        if (man.Isfree) and not (man.Freeing) and (man.destroycount = 0) then begin
          man.Isfree := false;
          result := tThreadBlockManager(man);
          break;
        end;
      finally
        man.Unlock;
      end;
    end;

    if not (result<>nil) then
      result := TThreadBlockManager.create;


  finally
    Unlock;
  end;
end;

procedure TBlockManagerManager.RegisterManager(bm: TBlockManager);
begin
  ManMan.Lock;
  try
    self.AddMan(bm);
  finally
    ManMan.Unlock;
  end;
end;


function TBlockManagerManager.TotalBlockCount: integer;
var
  t: integer;
begin
  result := 0;
  for t:= 0 to ManagerCount-1 do begin
    Managers[t].Lock;
    try
      inc(result, Managers[t].BlockCount);
    finally
      Managers[t].Unlock;
    end;
  end;

end;

function TBlockManagerManager.TotalFreeBytes: integer;
var
  t: integer;
begin
  result := 0;
  for t:= 0 to ManagerCount-1 do begin
    Managers[t].Lock;
    try
      inc(result, Managers[t].FreeBytes);
    finally
      Managers[t].Unlock;
    end;
  end;

end;

function TBlockManagerManager.TotalBytes: integer;
var
  t: integer;
begin
  result := 0;
  for t:= 0 to ManagerCount-1 do begin
    Managers[t].Lock;
    try
      inc(result, Managers[t].AllocBytes);
    finally
      Managers[t].Unlock;
    end;
  end;

end;



function TBlockManagerManager.TryLock: boolean;
begin
  result := TryEnterCriticalSection(sect);
end;

procedure TBlockManagerManager.Unlock;
begin
  LeaveCriticalSection(sect);
end;

procedure PatchEndThread;
// redirect calls to System.EndThread to NewNewThread
var
  EndThreadAddr:PJump;
  OldProtect,Protect:DWord;
begin
  EndThreadAddr:=Pointer(@EndThread);
  NewCode.Distance:=Integer(@NewEndThread)-(Integer(@EndThread)+5);
  {$IFNDEF LINUX}
  VirtualProtect(EndThreadAddr,5,PAGE_READWRITE,OldProtect);