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境界に揃える
  _NALLOC = 1024 * 64;                //64K   VirtualAllocは64K単位
  _NFREEALLOC = _NALLOC * 2;          //128K  後ろに128Kの空きができたら開放
  _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を使って全て予約
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;
//メモリ開放
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
    //ヘッダを得る
    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;
    //挿入位置p < bp < p.nextを探す
    //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  //ブロックの最後で
         //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}
      //一定量を開放する
      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);
  //最低サイズに揃える
  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;
  //メモリをリストに挿入
  _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
    //ヘッダを含めた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 //繰り上げ
        else begin
          //メモリの左から切り出す
          prev_p.next := POINTER(UINT(p) + size);
          prev_p.next.next := p.next;
          //サイズ調整
          prev_p.next._size := p._size - size;
          p._size := size;
        end;
        //使用メモリの先頭を返す
        //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;   
  
    //ヘッダを含めたsizeを得る
    nu := (nbytes + sizeOf(THeader) - 1) div _NALIGN + 1; //alignを揃える
    size := nu * _NALIGN;
    //ヘッダを得る
    bp := Pointer(UINT(ap) - SizeOf(THeader));
    //元が大きい場合はそのまま返す
    if bp._size >= size then
      Result := ap
    else begin
      Result := malloc(nbytes);
      //ヘッダ分を減らしてコピー
      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.