mempools.pas

由delphi实现的bt下载器示例程序

unit MemPools;

interface

//{$DEFINE LOG2FILE}

uses
  SysUtils, windows;

const
  BUCKET_INC = 1024;
  BLOCK_INC  = 32;

type
  TMemBlock = array [0..$10000000] of Integer;
  PMemBlock = ^TMemBlock;

  TMemPool = class
  private
    Lock: TRTLCriticalSection;

    BufSize: Integer;

    Blocks: array of PMemBlock;
    BlockE: Integer;

    Emptys: array of Integer;
    EmptyE: Integer;

    BigBuffer: Integer;
    BigBufferLen: Integer;

    Mask: Byte;
    ImgFile: string;
    ChgBlocks: array of Integer;
    ChgE: Integer;

    procedure DecodeHandle(H: Integer; var N, Ind: Integer);
    function EncodeHandle(N, Ind: Integer): Integer;

    function InnerAlloc(Size: Integer): Integer;
    procedure InnerDealloc(Handle: Integer);
    function NewBlock(Size: Integer): Integer;

    function FindPt(Handle: Integer; b, e: Integer; l: Integer = 0): Integer;
    procedure LoadImage(Filename: string);
    procedure AddChg(Ind: Integer);
    procedure CombineBlock(b, p, c, n: Integer);
  public
    constructor Create(SizeM: Integer = 4);
    constructor CreateFromFile(FileName: string);
    destructor Destroy; override;
    procedure AttachFile(FileName: string);
    function Alloc(Size: Integer; var p: Pointer):Integer;
    procedure Dealloc(Handle: Integer);
    function Realloc(var Handle: Integer; Size: Integer): Pointer;
    procedure SaveChanges;
    procedure SaveImage(FileName: string);
    function Handle2Pointer(Handle: Integer; Len: PInteger = nil): Pointer;
    function MemLen(Handle: Integer): Integer;
    function DebugMem: string;
  end;

{ Fixed memory pool } 

  TFixedMemPool = class
    Lock: TRTLCriticalSection;
    BlockSize: Cardinal;
    IncValue: Cardinal;
    Buffers: array of Pointer;
    Emptys: array of Pointer;
    EmptyB, EmptyE: Cardinal;
    Translater: array of Cardinal;
    TransIdx: array of word;
    BigBuffer: Cardinal;
    BigBufLen: Cardinal;
    constructor Create(ABlockSize, IncreaseCnt: Cardinal);
    destructor Destroy; override;
    function Get: Pointer;
    procedure Put(p: Pointer);
    procedure SaveToFile(FName: string);
    procedure LoadFromFile(FName: string);
    procedure SaveToFileId(Fid: Integer);
    procedure LoadFromFileId(Fid: Integer);
    procedure Translate(var Buf; Cnt: Integer);
  end;

{****** First in first out buffer ******}
  PFIFOBlock = ^TFIFOBlock;
  TFIFOBlock = record
    Next: PFIFOBlock;
    B, E: Cardinal;
  end;

  TFIFOBuffer = class
    First, Current, Last: PFIFOBlock;
    BlockSize: Cardinal;
    Lock: TRTLCriticalSection;
    TotalSize: Cardinal;
    EndPort: Pointer;
    constructor Create(ABlockSize: Integer);
    destructor Destroy; override;
    procedure Clear;
    procedure Push(AValue: Cardinal);
    function Peek(var AValue: Cardinal): Boolean;
    procedure Jump;
    function Pop(var AValue: Cardinal): Boolean;
    procedure SetEndPort;
  end;

procedure DebugOut(s: string);

implementation

procedure DebugOut(s: string);
{$IFDEF LOG2FILE}
var
  id: Integer;
  tmp: string;
{$ENDIF}
begin
{$IFDEF LOG2FILE}
  tmp := formatdatetime('hh:nn:ss:ms', now)+#9+s+#13#10;
  if not fileexists('d:\debuglog'+inttostr(getcurrentprocessId)+'.log') then
    id := filecreate('d:\debuglog'+inttostr(getcurrentprocessId)+'.log')
  else
    id := fileopen('d:\debuglog'+inttostr(getcurrentprocessId)+'.log', fmOpenWrite or fmShareDenyNone);
  fileseek(id, 0, 2);
  filewrite(id, tmp[1], length(tmp));
  fileclose(id);
{$ELSE}
  outputdebugstring(pchar(s));
{$ENDIF}
end;

{ TMemPool }

constructor TMemPool.Create(SizeM: Integer);
begin
  if SizeM<=4 then Mask := 3
  else if sizeM <= 64 then Mask := 2
  else Mask := 1;
  BufSize:=SizeM * 1024 * 256;
  initializecriticalsection(lock);
end;

constructor TMemPool.CreateFromFile(FileName: string);
begin
  initializecriticalsection(lock);
  ImgFile := FileName;
  if fileexists(filename) then
    loadimage(filename)
  else create(4);
end;

destructor TMemPool.Destroy;
var
  i: Integer;
begin
  SaveChanges;
  entercriticalsection(lock);
  try
    for i := 0 to blocke-1 do
    begin
      if (cardinal(blocks[i])<= cardinal(bigbuffer)) or
        (cardinal(blocks[i]) >= cardinal(bigbuffer+bigbufferlen)) then
        dispose(blocks[i]);
    end;
  except
  end;
  leavecriticalsection(lock);
  inherited;
  deletecriticalsection(lock);
end;

function TMemPool.Alloc(Size: Integer; var p: Pointer): Integer;
begin
  result := 0;
  entercriticalsection(lock);
  try
    result := inneralloc(size);
  except
    on e: exception do
      debugout('Alloc ERROR!!! '+inttostr(size)+'/'+inttostr(result)+':'+e.Message);
  end;
  p := handle2pointer(result);
  leavecriticalsection(lock);
end;

procedure TMemPool.Dealloc(Handle: Integer);
begin
  entercriticalsection(lock);
  try
    Innerdealloc(handle);
  except
    on e: exception do
      debugout('Dealloc ERROR!!!'+inttostr(handle)+':'+e.Message);
  end;
  leavecriticalsection(lock);
end;

function TMemPool.Realloc(var Handle: Integer; Size: Integer): Pointer;
var
  p1: Pointer;
  l1, l2: Integer;
begin
  entercriticalsection(lock);
  try
    result := handle2pointer(handle, @l1);
    p1 := result;
    l2 := (size + 3) shr 2;
    l2 := l2 shl 2;
    if l1 <> l2 then
    begin
      if handle <> 0 then
        innerdealloc(handle);
      handle := 0;
      result := nil;
      if size > 0 then
      begin
        handle := inneralloc(size);
        result := handle2pointer(handle, @l2);
        if (p1 <> result) and (p1 <> nil) then
          if l1 < l2 then
            move(p1^, result^, l1)
          else move(p1^, result^, l2);
      end;
    end;
  except
    on e: exception do
    begin
      debugout('Realloc ERROR!!! '+IntToHex(Handle, 8)+'  '+inttostr(size)+':'+e.Message);
      result := nil;
    end;
  end;
  leavecriticalsection(lock);
end;

procedure TMemPool.DecodeHandle(H: Integer; var N, Ind: Integer);
var
  msk: Integer;
begin
  n := (H shr (31-mask*4));
  msk := $FFFFFFFF shr (mask*4);
  ind := (H and msk);
end;

function TMemPool.EncodeHandle(N, Ind: Integer): Integer;
begin
  result := (n shl (32-mask*4)) or Ind;
end;

function TMemPool.Handle2Pointer(Handle: Integer; Len: PInteger): Pointer;
var
  n, Ind: Integer;
begin
  if Handle = 0 then
  begin
    result := nil;
    if len <> nil then
      len^ := 0;
  end
  else begin
    decodehandle(handle, n, ind);
    if ind = 0 then
    begin
      result := nil;
      if len <> nil then
        len^ := 0;
    end
    else begin
      result := pointer(Integer(@(blocks[n][ind]))+4);
      if assigned(len) then
        len^ := (blocks[n][ind] and $7FFFFFFF - 2) shl 2;
    end;
  end;
end;

function TMemPool.InnerAlloc(Size: Integer): Integer;
var
  b, e, c, x: Integer;
  i, n, l, l1, h: Integer;
begin
  size := (size + 11) shr 2;
  b := 0;
  e := emptye-1;
  while b <= e do
  begin
    c := (b + e) shr 1;
    decodehandle(emptys[c], i, n);
    l := blocks[i][n] and $7FFFFFFF;
    if l > size then e := c - 1
    else if l < size then b := c + 1
    else begin
      b := c;
      break;
    end;
  end;
  if b = Integer(emptye) then
  begin
    result := NewBlock(size);
    exit;
  end;
  x := b;
  result := emptys[x];
  decodehandle(result, i, n);
  AddChg(i);
  l := blocks[i][n] - size;
  if l > 0 then
  begin
    blocks[i][n+size] := l;
    blocks[i][n+size+l-1] := l;
  end;
  blocks[i][n] := cardinal(size) or $80000000;
  blocks[i][n+size-1] := size;
  if l > 0 then
  begin
    h := encodehandle(i, n+size);
    b := 0;
    e := x-1;
    while b <= e do
    begin
      c := (b + e) shr 1;
      decodehandle(emptys[c], i, n);
      l1 := blocks[i][n] and $7FFFFFFF;
      if l1 > l then e := c - 1
      else if l1 < l then b := c + 1
      else if emptys[c] > h then e := c - 1
      else if emptys[c] < h then b := c + 1
      else begin
        b := c;
        break;
      end;
    end;
    move(emptys[b], emptys[b+1], (x-b)*4);
    emptys[b] := h;
  end
  else begin
    dec(emptye);
    move(emptys[b+1], emptys[b], (emptye-Integer(b))*4);
  end;
end;

procedure TMemPool.InnerDealloc(Handle: Integer);
var
  i, n, pn, nn: Integer;

begin
  decodehandle(handle, i, n);
  if (n = 0) or (n>= bufsize) or (i>= blocke) then exit;
  AddChg(i);
  blocks[i][n] := blocks[i][n] and $7FFFFFFF;
  if n > 1 then
    pn := n - blocks[i][n-1]
  else pn := 0;
  if n < blocks[i][0]-1 then
    nn := n + blocks[i][n]
  else nn := 0;
  combineblock(i, pn, n, nn);
end;

function TMemPool.FindPt(Handle: Integer; b, e, l: Integer): Integer;
var
  c: Integer;
  i, n, l1: Integer;
begin
  decodehandle(handle, i, n);
  if l = 0 then
    l := blocks[i][n] and $7FFFFFFF;
  while b <= e do
  begin
    c := (b + e) shr 1;
    decodehandle(emptys[c], i, n);
    l1 := blocks[i][n] and $7FFFFFFF;
    if l1 > l then e := c - 1
    else if l1 < l then b := c + 1
    else if emptys[c] > handle then e := c - 1
    else if emptys[c] < handle then b := c + 1
    else begin
      b := c;
      break;
    end;
  end;
  result := b;
end;

function TMemPool.NewBlock(Size: Integer): Integer;
var
  p: PMemBlock;
  n, h: Integer;
begin
  n := blocke;
  result := encodehandle(n, 1);
  if blocke > high(blocks) then
  begin
    setlength(blocks, length(blocks)+BLOCK_INC);
    setlength(chgblocks, length(blocks));
  end;
  inc(blocke);
  getmem(p, bufSize * 4);
  blocks[blocke-1] := p;
  addchg(blocke-1);
  p[0] := bufSize-1;
  p[1] := cardinal(size) or $80000000;
  p[size] := size;
  if size < p[0] then
  begin
    h := encodehandle(n, size+1);
    p[size+1] := p[0]-size;
    p[p[0]] := p[0]-size;
    n := findpt(h, 0, emptye-1);
    if emptye > high(emptys) then
      setlength(emptys, length(emptys)+BUCKET_INC);
    move(emptys[n], emptys[n+1], (emptye-n)*4);
    inc(emptye);
    emptys[n] := h;
  end;
end;

procedure TMemPool.SaveImage(FileName: string);
var
  fid, i: Integer;
begin
  if filename = imgfile then
    savechanges
  else begin
    entercriticalsection(lock);
    try
    fid := filecreate(filename);
    filewrite(fid, BufSize, 4);
    filewrite(fid, mask, 1);
    filewrite(fid, blocke, 4);
    for i := 0 to blocke-1 do
      filewrite(fid, blocks[i]^[0], BufSize*4);
    filewrite(fid, emptye, 4);
    filewrite(fid, emptys[0], emptye*4);
    fileclose(fid);
    Chge := 0;
    except
    end;
    leavecriticalsection(lock);
  end;
end;

procedure TMemPool.LoadImage(Filename: string);
var
  fid, i, n: Integer;
begin
  fid := fileopen(filename, fmOpenRead or fmShareDenyNone);
  fileread(fid, BufSize, 4);
  fileread(fid, mask, 1);
  fileread(fid, blocke, 4);
  bigbufferlen := BufSize*blocke*4;
  getmem(pointer(bigbuffer), bigbufferlen);
  if bigbufferlen > 0 then
    fileread(fid, pbyte(bigbuffer)^, bigbufferlen);
  setlength(blocks, blocke);
  setlength(chgblocks, blocke);
  chge := 0;
  n := bigbuffer;
  for i := 0 to blocke-1 do
  begin
    blocks[i] := pointer(n);
    inc(n, BufSize*4);
  end;
  fileread(fid, emptye, 4);
  setlength(emptys, emptye+BUCKET_INC);
  if length(emptys)>0 then
    fileread(fid, emptys[0], emptye*4);
  fileclose(fid);
end;

function TMemPool.MemLen(Handle: Integer): Integer;
begin
  handle2pointer(handle, @result);
end;

procedure TMemPool.AddChg(Ind: Integer);
var
  b, e, c: Integer;
begin
  b := 0;
  e := chge-1;
  while b <= e do
  begin
    c := (b + e) shr 1;
    if chgblocks[c] > Ind then e := c -1
    else if chgblocks[c] < Ind then b := c + 1
    else exit;
  end;
  move(chgblocks[b], chgblocks[b+1], (chge-b)*4);
  inc(chge);
  chgblocks[b] := Ind;
end;

procedure TMemPool.AttachFile(FileName: string);
begin
  if filename <> '' then
    saveimage(filename);
  imgfile := filename;
end;

procedure TMemPool.SaveChanges;
var
  fid, i, n: Integer;
  Offset: Int64;
begin
  if (imgfile <> '') and (chge > 0) then
  begin
    entercriticalsection(lock);
    try
    if fileexists(imgfile) then
      fid := fileopen(imgfile, fmOpenReadWrite or fmShareDenyNone)
    else
      fid := filecreate(imgfile);
    filewrite(fid, bufsize, 4);
    filewrite(fid, mask, 1);
    filewrite(fid, blocke, 4);
    for i := 0 to chge - 1 do
    begin
      n := chgblocks[i];
      offset := bufsize*n*4+9;
      fileseek(fid, offset, 0);
      filewrite(fid, blocks[n][0], bufsize*4);
    end;
    chge := 0;
    Offset := bufsize*blocke*4+9;
    fileseek(fid, offset, 0);
    filewrite(fid, emptye, 4);
    if emptye > 0 then
      filewrite(fid, emptys[0], emptye*4);
    setendoffile(fid);
    fileclose(fid);
    except
    end;