Netrunner 2004 October/NETRUNNER0410.ISO/regular/irvine1_0_9.lzh/mmgr/source/xmalloc.pas

Pascal/Delphi Source File | 2003-05-19 | 12KB | 619 lines

unit xmalloc;

{
  K&R C 2nd malloc
}

{..$DEFINE REPLACE_MANAGER}
{..$DEFINE HEAP_PROFILE}
{..$DEFINE CONSOLE_TEST}
{$DEFINE HEAP_DECOMMIT}

interface

uses
  windows;

function malloc(nbytes: Integer): Pointer;
function free(ap: Pointer): Integer;
function realloc(ap: Pointer; nbytes: Integer): Pointer;

{$IFDEF CONSOLE_TEST}
procedure test;
procedure test2;
procedure test3;
procedure test4;
procedure test5;
procedure test6;
{$ENDIF}

implementation

type
  PHeader = ^THeader;
  THeader = packed record
    next: PHeader;
    _size: UINT;
  end;

  PHeap = ^THeap;
  THeap = record
    heap_base: PHeader;
    heap_reserve: UINT;
    heap_left: Pointer;
  end;

  PCore = ^TCore;
  TCore = record
    base: THeader;
    free_p: PHeader;
    heap: PHeap;
  end;

const
  _NALIGN = SizeOf(THeader);          //8     8bytesï½èEé╔æ╡éªéΘ
  _NALLOC = 1024 * 64;                //64K   VirtualAllocé═64KÆPê╩
  _NFREEALLOC = _NALLOC * 2;          //128K  îπéδé╔128Ké╠ï≤é½é¬é┼é½é╜éτèJò·
  _NCORE = 128 div 4 - 8;             //24    1byteü`192bytesé╞é╗éΩê╚ì~é≡24é╠free_pé┼è╟ù¥
  _NHEAP = 8;                         //8     16bytesü`64bytesé≡ô┴ò╩ê╡éó
  _NRESERVE = _NALLOC * 1024 div 2;   //32M   16bytesü`64bytesé╔é╗éΩé╝éΩ32MèäéΦôûé─
  _NRESERVE_BIG = _NALLOC * 1024 * 2; //128M  192bytesê╚ì~é╔128MèäéΦôûé─


var
  cores: array[0..pred(_NCORE)] of TCore;
  heaps: array[0..pred(_NHEAP)] of THeap;

  corelock: TRTLCriticalSection;

{$IFDEF HEAP_PROFILE}
  ntotal: array[0..pred(_NCORE)] of UINT;
{$ENDIF}

{$IFDEF CONSOLE_TEST}
  nblocks: UINT;
{$ENDIF}

function selectcore(size: UINT): PCore;
//8 ü` 192é▄é┼
var
  n: UINT;
begin
  n := size div _NALIGN;
  if n > pred(_NCORE) then
    n := 0;

  Result := @cores[n];
end;

procedure malloc_init;
//virtualallocé≡Ägé┴é─æSé─ù\û±
var
  i,n: Integer;
begin
  for i := 0 to pred(_NHEAP) do
  begin
    if i = 0 then
      heaps[i].heap_reserve := _NRESERVE_BIG
    else
      heaps[i].heap_reserve := _NRESERVE;

    while True do
    begin
      heaps[i].heap_base :=
        VirtualAlloc(nil,heaps[i].heap_reserve,MEM_RESERVE,PAGE_NOACCESS);
      //reserveé≡î╕éτé╖
      if heaps[i].heap_base = nil then
        heaps[i].heap_reserve := heaps[i].heap_reserve shr 1
      else
        break;
    end;

    heaps[i].heap_left := heaps[i].heap_base;
  end;

  for i := 0 to pred(_NCORE) do
  begin
    cores[i].base.next := @cores[i].base;
    cores[i].free_p := @cores[i].base;
    cores[i].base._size := 0;

    case i of
      0: n := 0;
      2..pred(_NHEAP): n := i - 1;
    else
      n := pred(_NHEAP);
    end;

    cores[i].heap := @heaps[n];
  end;
end;

procedure malloc_free;
//âüâéâèèJò·
var
  i: Integer;
begin
{$IFDEF CONSOLE_TEST}
  writeln('blocks: ',nblocks);
{$ENDIF}
  for i := 0 to pred(_NHEAP) do
  begin
    VirtualFree(heaps[i].heap_base,heaps[i].heap_reserve,MEM_DECOMMIT);
    VirtualFree(heaps[i].heap_base,0,MEM_RELEASE);
  end;

{$IFDEF HEAP_PROFILE}
  Inc(ntotal[0]);
{$ENDIF}
end;

function _free(ap: Pointer; core: PCore): Integer;
//âüâéâèé≡free_pé╔û▀é╖
var
  bp,p: PHeader;
  del,more: Boolean;
begin
  Result := 0;
  //nilé╠ÅΩìçé═ë╜éαé╡é╚éó
  if ap = nil then
    Exit;

  EnterCriticalSection(corelock);
  try
    //âwâbâ_é≡ô╛éΘ
    bp := Pointer(UINT(ap) - SizeOf(THeader));
    if core = nil then
    begin
      core := selectcore(bp._size);
      more := False;
    end
    else
      more := True;

    p := core.free_p;
    //æ}ôⁿê╩Æup < bp < p.nexté≡ÆTé╖
    //bpé¬pé╞p.nexté╠è╘é╔é╚é»éΩé╬
    while not ((UINT(p) < UINT(bp)) and (UINT(bp) < UINT(p.next))) do
    begin
      if ((UINT(p) >= UINT(p.next)) and  //âuâìâbâNé╠ì┼îπé┼
         //bpé¬péµéΦæσé½éóé▄é╜é═bpé¬nextéµéΦżé│éó
         ((UINT(p) < UINT(bp)) or (UINT(bp) < UINT(p.next)))) then
        break;

      //ăé╓
      p := p.next;
    end;

    //bpé¬nexté╞É┌é╡é─éóéΘÅΩìç
    if (UINT(bp) + bp._size) = UINT(p.next) then
    begin
      //bpé╞nexté╞ò╣ìç
      bp._size := bp._size + p.next._size;
      bp.next := p.next.next;

{$IFDEF HEAP_DECOMMIT}
      //êΩÆΦù╩é≡èJò·é╖éΘ
      if (not more) and (bp._size >= _NFREEALLOC) and
         ((UINT(bp) + bp._size) = UINT(core.heap.heap_left)) then
      begin
  {$IFDEF CONSOLE_TEST}
        writeln('free: ',UINT(bp),' ',_NFREEALLOC);
        Dec(nblocks);
  {$ENDIF}
        if bp._size = _NFREEALLOC then
        begin
          //bpé═Å┴û┼é╖éΘ
          p.next := bp.next;
          del := True;
        end
        else begin
          bp._size := bp._size - _NFREEALLOC;
          del := False;
        end;

        UINT(core.heap.heap_left) := UINT(core.heap.heap_left) - _NFREEALLOC;
        VirtualFree(core.heap.heap_left,_NFREEALLOC,MEM_DECOMMIT);

        if del then
        begin
          //if core = @cores[0] then
            //core.free_p := p;

          Exit;
        end;
      end;
{$ENDIF}
    end
    else //É┌é╡é─éóé╚éóÅΩìçé═æ}ôⁿ
      bp.next := p.next;

    //pé╞bpé¬É┌é╡é─éóéΘÅΩìç
    if (UINT(p) + p._size) = UINT(bp) then
    begin
      //pé╞bpé≡ò╣ìç
      p._size := p._size + bp._size;
      p.next := bp.next;
    end
    else//É┌é╡é─éóé╚éóÅΩìçé═æ}ôⁿ
      p.next := bp;

{$IFDEF HEAP_DECOMMIT}
    if (not more) and (p._size > _NFREEALLOC) and
       ((UINT(p) + p._size) = UINT(core.heap.heap_left)) then
    begin
      UINT(core.heap.heap_left) := UINT(core.heap.heap_left) - _NFREEALLOC;
      p._size := p._size - _NFREEALLOC;
      VirtualFree(core.heap.heap_left,_NFREEALLOC,MEM_DECOMMIT);

  {$IFDEF CONSOLE_TEST}
      writeln('free: ',UINT(p),' ',_NFREEALLOC);
      Dec(nblocks);
  {$ENDIF}
    end;
{$ENDIF}
    //if core = @cores[0] then
      //core.free_p := p;
  finally
    LeaveCriticalSection(corelock);
  end;
end;

function morecore(size: UINT): PHeader;
//virtualallocé⌐éτâüâéâèé≡commit
var
  p: PHeader;
  n: UINT;
  c: PCore;
begin
  c := selectcore(size);
  //ì┼ÆßâTâCâYé╔æ╡éªéΘ
  n := (size - 1) div _NALLOC + 1;
  size := n * _NALLOC;

  p := VirtualAlloc(c.heap.heap_left,size,MEM_COMMIT,PAGE_READWRITE);

  ASSERT(p = c.heap.heap_left);

{$IFDEF CONSOLE_TEST}
  writeln(UINT(p),' ',size);
  Inc(nblocks);
{$ENDIF}

  //ì╢Æ[é≡ê┌ô«
  UINT(c.heap.heap_left) := UINT(c.heap.heap_left) + size;

  p._size := size;
  //âüâéâèé≡âèâXâgé╔æ}ôⁿ
  _free(POINTER(UINT(p) + SizeOf(THeader)),c);
  Result := p;
end;

function malloc(nbytes: Integer): Pointer;
var
  p,prev_p: PHeader;
  nu,size: UINT;
  c: PCore;
begin
  EnterCriticalSection(corelock);
  try
    //âwâbâ_é≡è▄é▀é╜sizeé≡ô╛éΘ
    nu := (nbytes + sizeOf(THeader) - 1) div _NALIGN + 1; //aligné≡æ╡éªéΘ
    size := nu * _NALIGN;
    if nu > pred(_NCORE) then
      nu := 0;

    c := @cores[nu];
    //c := selectcore(size);
{$IFDEF HEAP_PROFILE}
    Inc(ntotal[nu]);
{$ENDIF}

    prev_p := c.free_p;
    p := prev_p.next;

    //first fit
    while True do
    begin
      //Å\ò¬é╔æσé½éó
      if p._size >= size then
      begin
        //é╥é┴é╜éΦ
        if p._size = size then
          prev_p.next := p.next //îJéΦÅπé░
        else begin
          //âüâéâèé╠ì╢é⌐éτÉ╪éΦÅoé╖
          prev_p.next := POINTER(UINT(p) + size);
          prev_p.next.next := p.next;
          //âTâCâYÆ▓É«
          prev_p.next._size := p._size - size;
          p._size := size;
        end;
        //Ägùpâüâéâèé╠ɵô¬é≡ò╘é╖
        //if c = @cores[0] then
        //  c.free_p := prev_p;

        Result := Pointer(UINT(p) + SizeOf(THeader));
        Exit;
      end;

      if p = c.free_p then
      begin
        morecore(size);
        p := c.free_p;
      end;

      //ăé╓
      prev_p := p;
      p := p.next;
    end;

  finally
    LeaveCriticalSection(corelock);
  end;
end;

function free(ap: Pointer): Integer;
begin
  Result := _free(ap,nil);
end;

function realloc(ap: Pointer; nbytes: Integer): Pointer;
var
  bp: PHeader;
  nu,size: UINT;
begin
  EnterCriticalSection(corelock);
  try
    //nilé╠ÅΩìç
    if ap = nil then
    begin
      if nbytes > 0 then
        Result := malloc(nbytes)
      else
        Result := nil;

      Exit;
    end
    else if nbytes = 0 then
    begin
      free(ap);
      Result := nil;
      Exit;
    end;

    //âwâbâ_é≡è▄é▀é╜sizeé≡ô╛éΘ
    nu := (nbytes + sizeOf(THeader) - 1) div _NALIGN + 1; //aligné≡æ╡éªéΘ
    size := nu * _NALIGN;
    //âwâbâ_é≡ô╛éΘ
    bp := Pointer(UINT(ap) - SizeOf(THeader));
    //î│é¬æσé½éóÅΩìçé═é╗é╠é▄é▄ò╘é╖
    if bp._size >= size then
      Result := ap
    else begin
      Result := malloc(nbytes);
      //âwâbâ_ò¬é≡î╕éτé╡é─âRâsü[
      move(ap^,Result^,bp._size - SizeOf(THeader));
      free(ap);
    end;
  finally
    LeaveCriticalSection(corelock);
  end;
end;

{$IFDEF REPLACE_MANAGER}
var
  oldmgr: TMemoryManager;

const
  newmgr: TMemoryManager =
  (
    GetMem: malloc;
    FreeMem: free;
    ReAllocMem: realloc;
  );

procedure memorymanager_init;
begin
  GetMemoryManager(oldmgr);
  SetMemoryManager(newmgr);
end;

procedure memorymanager_free;
begin
  SetMemoryManager(oldmgr);
end;
{$ENDIF}


{$IFDEF CONSOLE_TEST}
type
  PItem = ^TItem;
  TItem = record
    next: PItem;
    p: Pointer;
  end;

procedure test6;
var
  x,y: Integer;
  a,b,nxt: PItem;
begin
  writeln('test6');

  for x := 0 to 10000 div 2 do
  begin
    a := nil;

    for y := 0 to Random(2550) do
    begin
      b := malloc(SizeOf(TItem));
      b.p := malloc(Random(2550));

      b.next := a;
      a := b;

      b := malloc(SizeOf(TItem));
      b.p := malloc(Random(128));

      b.next := a;
      a := b;
    end;

    while a <> nil do
    begin
      nxt := a.next;
      free(a.p);
      free(a);
      a := nxt;
    end;
  end;
end;


procedure test5;
var
  a,b,c,d,e: pointer;
  i: Integer;
begin
  writeln('test5');

  for i := 0 to 1000000 do
  begin
    a := malloc(8);
    b := malloc(255);
    c := malloc(65535);
    //d := malloc(65535 * 2);
    e := malloc(10);

    free(e);
    //free(d);
    free(c);
    free(b);
    free(a);
  end;
end;

procedure test;
var
  a,b,c,d,e: pointer;
  i: Integer;
begin
  writeln('test');

  for i := 0 to 1000000 do
  begin
    a := malloc(Random(8));
    b := malloc(Random(255));
    c := malloc(Random(65535));
    //d := malloc(Random(65535 * 2));
    e := malloc(Random(10));

    a := realloc(a,10);

    free(e);
    //free(d);
    free(c);
    free(b);
    free(a);
  end;
end;

procedure test3;
var
  a,b,c,d,e: pointer;
  i: Integer;
begin
  writeln('test3');

  for i := 0 to 1000000 do
  begin
    a := malloc(20);
    b := malloc(20);
    c := malloc(20);
    d := malloc(20);
    e := malloc(20);

    a := realloc(a,20);
    b := realloc(b,10);
    c := realloc(c,30);

    free(e);
    free(d);
    free(c);
    free(b);
    free(a);
  end;
end;

procedure test4;
var
  a,b,c,d,e: pointer;
  i: Integer;
begin
  writeln('test4');

  for i := 0 to 1000000 do
  begin
    a := malloc(Random(65536));
    free(a);

    b := malloc(Random(65536));
    free(b);

    c := malloc(Random(65536));
    free(c);

    d := malloc(Random(65536));
    free(d);

    e := malloc(Random(65536));
    free(e);

    //free(e);
    //free(d);
    //free(c);
    //free(b);
    //free(a);
  end;
end;

procedure test2;
var
  a,b,c,d,e: pointer;
  i: Integer;
begin
  writeln('test2');

  for i := 0 to 1000000 do
  begin
    GetMem(a,8);
    GetMem(b,255);
    GetMem(c,65535);
    GetMem(d,65535 * 2);
    GetMem(e,10);

    freeMem(e);
    freeMem(d);
    freeMem(c);
    freeMem(b);
    freeMem(a);
  end;
end;

{$ENDIF}

initialization
  InitializeCriticalSection(corelock);
{$IFDEF REPLACE_MANAGER}
  memorymanager_init;
{$ENDIF}
  malloc_init;
finalization
  malloc_free;
{$IFDEF REPLACE_MANAGER}
  memorymanager_free;
{$ENDIF}
  DeleteCriticalSection(corelock);

end.