//
// Suballocator (what the user program actually calls)
//

type
  PFree = ^TFree;
  TFree = packed record
    prev: PFree;
    next: PFree;
    size: Integer;
  end;
  PUsed = ^TUsed;
  TUsed = packed record
    sizeFlags: Integer;
  end;

const
  cAlign        = 4;
  cThisUsedFlag = 2;
  cPrevFreeFlag = 1;
  cFillerFlag   = Integer($80000000);
  cFlags        = cThisUsedFlag or cPrevFreeFlag or cFillerFlag;
  cSmallSize    = 4*1024;
  cDecommitMin  = 15*1024;

type
  TSmallTab    = array [sizeof(TFree) div cAlign .. cSmallSize div cAlign] of PFree;

VAR
  avail        : TFree;
  rover        : PFree;
  remBytes     : Integer;
  curAlloc     : PChar;
  smallTab     : ^TSmallTab;
  committedRoot: TBlockDesc;


function InitAllocator: Boolean;
// Initialize. No other calls legal before that.
var
  i: Integer;
  a: PFree;
begin
  try
    InitializeCriticalSection(heapLock);
    if IsMultiThread then EnterCriticalSection(heapLock);

    MakeEmpty(@spaceRoot);
    MakeEmpty(@decommittedRoot);
    MakeEmpty(@committedRoot);

    smallTab := LocalAlloc(LMEM_FIXED, sizeof(smallTab^));
    if smallTab <> nil then begin
      for i:= low(smallTab^) to high(smallTab^) do
        smallTab[i] := nil;

      a := @avail;
      a.next := a;
      a.prev := a;
      rover := a;

      initialized := True;
    end;
  finally
    if IsMultiThread then LeaveCriticalSection(heapLock);
  end;
  result := initialized;
end;


procedure UninitAllocator;
// Shutdown.
var
  bdb: PBlockDescBlock;
  bd : PBlockDesc;
begin
  if initialized then begin
    try
      if IsMultiThread then EnterCriticalSection(heapLock);

      initialized := False;

      LocalFree(smallTab);
      smallTab := nil;

      bd := spaceRoot.next;
      while bd <> @spaceRoot do begin
        VirtualFree(bd.addr, 0, MEM_RELEASE);
        bd := bd.next;
      end;

      MakeEmpty(@spaceRoot);
      MakeEmpty(@decommittedRoot);
      MakeEmpty(@committedRoot);

      bdb := blockDescBlockList;
      while bdb <> nil do begin
        blockDescBlockList := bdb^.next;
        LocalFree(bdb);
        bdb := blockDescBlockList;
      end;
    finally
      if IsMultiThread then LeaveCriticalSection(heapLock);
      DeleteCriticalSection(heapLock);
    end;
  end;
end;


procedure DeleteFree(f: PFree);
var
  n, p: PFree;
  size: Integer;
begin
  if rover = f then
    rover := f.next;
  n := f.next;
  size := f.size;
  if size <= cSmallSize then begin
    if n = f then
      smallTab[size div cAlign] := nil
    else begin
      smallTab[size div cAlign] := n;
      p := f.prev;
      n.prev := p;
      p.next := n;
    end;
  end else begin
    p := f.prev;
    n.prev := p;
    p.next := n;
  end;
end;


procedure InsertFree(a: Pointer; size: Integer); forward;


function FindCommitted(addr: PChar): PBlockDesc;
begin
  result := committedRoot.next;
  while result <> @committedRoot do begin
    if (addr >= result.addr) and (addr < result.addr + result.size) then
      exit;
    result := result.next;
  end;
  heapErrorCode := cBadCommittedList;
  result := nil;
end;


procedure FillBeforeGap(a: PChar; size: Integer);
var
  rest: Integer;
  e: PUsed;
begin
  rest := size - sizeof(TUsed);
  e := PUsed(a + rest);
  if size >= sizeof(TFree) + sizeof(TUsed) then begin
    e.sizeFlags := sizeof(TUsed) or cThisUsedFlag or cPrevFreeFlag or cFillerFlag;
    InsertFree(a, rest);
  end else if size >= sizeof(TUsed) then begin
    PUsed(a).sizeFlags := size or (cThisUsedFlag or cFillerFlag);
    e.sizeFlags := size or (cThisUsedFlag or cFillerFlag);
  end;
end;


procedure InternalFreeMem(a: PChar);
begin
  Inc(AllocMemCount);
  Inc(AllocMemSize,PUsed(a-sizeof(TUsed)).sizeFlags and not cFlags - sizeof(TUsed));
  SysFreeMem(a);
end;


procedure FillAfterGap(a: PChar; size: Integer);
begin
  if size >= sizeof(TFree) then begin
    PUsed(a).sizeFlags := size or cThisUsedFlag;
    InternalFreeMem(a + sizeof(TUsed));
  end else begin
    if size >= sizeof(TUsed) then
      PUsed(a).sizeFlags := size or (cThisUsedFlag or cFillerFlag);
    Inc(a,size);
    PUsed(a).sizeFlags := PUsed(a).sizeFlags and not cPrevFreeFlag;
  end;
end;


function FillerSizeBeforeGap(a: PChar): Integer;
var
  sizeFlags : Integer;
  freeSize  : Integer;
  f : PFree;
begin
  sizeFlags := PUsed(a - sizeof(TUsed)).sizeFlags;
  if (sizeFlags and (cThisUsedFlag or cFillerFlag)) <> (cThisUsedFlag or cFillerFlag) then
    heapErrorCode := cBadFiller1;
  result := sizeFlags and not cFlags;
  Dec(a, result);
  if ((PUsed(a).sizeFlags xor sizeFlags) and not cPrevFreeFlag) <> 0 then
    HeapErrorCode := cBadFiller2;
  if (PUsed(a).sizeFlags and cPrevFreeFlag) <> 0 then begin
    freeSize := PFree(a - sizeof(TFree)).size;
    f := PFree(a - freeSize);
    if f.size <> freeSize then
      heapErrorCode := cBadFiller3;
    DeleteFree(f);
    Inc(result, freeSize);
  end;
end;


function FillerSizeAfterGap(a: PChar): Integer;
var
  sizeFlags: Integer;
  f : PFree;
begin
  result := 0;
  sizeFlags := PUsed(a).sizeFlags;
  if (sizeFlags and cFillerFlag) <> 0 then begin
    sizeFlags := sizeFlags and not cFlags;
    Inc(result,sizeFlags);
    Inc(a, sizeFlags);
    sizeFlags := PUsed(a).sizeFlags;
  end;
  if (sizeFlags and cThisUsedFlag) = 0 then begin
    f := PFree(a);
    DeleteFree(f);
    Inc(result, f.size);
    Inc(a, f.size);
    PUsed(a).sizeFlags := PUsed(a).sizeFlags and not cPrevFreeFlag;
  end;
end;


function DecommitFree(a: PChar; size: Integer): Boolean;
var
  b: TBlock;
  bd: PBlockDesc;
begin
  bd := FindCommitted(a);
  if bd.addr + bd.size - (a + size) <= sizeof(TFree) then
    size := bd.addr + bd.size - a;

  if a - bd.addr < sizeof(TFree) then
    b := FreeCommitted(bd.addr, size + (a - bd.addr))
  else
    b := FreeCommitted(a + sizeof(TUsed), size - sizeof(TUsed));

  if b.addr = nil then
    result := False
  else begin
    FillBeforeGap(a, b.addr - a);
    if bd.addr + bd.size > b.addr + b.size then
      FillAfterGap(b.addr + b.size, a + size - (b.addr + b.size));
    RemoveBlock(bd,b);
    result := True;
  end;
end;


procedure InsertFree(a: Pointer; size: Integer);
var
  f, n, p: PFree;
begin
  f := PFree(a);
  f.size := size;
  PFree(PChar(f) + size - sizeof(TFree)).size := size;
  if size <= cSmallSize then begin
    n := smallTab[size div cAlign];
    if n = nil then begin
      smallTab[size div cAlign] := f;
      f.next := f;
      f.prev := f;
    end else begin
      p := n.prev;
      f.next := n;
      f.prev := p;
      n.prev := f;
      p.next := f;
    end;
  end else if (size < cDecommitMin) or not DecommitFree(a, size) then begin
    n := rover;
    rover := f;
    p := n.prev;
    f.next := n;
    f.prev := p;
    n.prev := f;
    p.next := f;
  end;
end;


procedure FreeCurAlloc;
begin
  if remBytes > 0 then begin
    if remBytes < sizeof(TFree) then
      heapErrorCode := cBadCurAlloc
    else begin
      PUsed(curAlloc).sizeFlags := remBytes or cThisUsedFlag;
      InternalFreeMem(curAlloc + sizeof(TUsed));
      curAlloc := nil;
      remBytes := 0;
    end;
  end;
end;


function MergeCommit(b: TBlock): Boolean;
var
  merged: TBlock;
  fSize: Integer;
begin
  FreeCurAlloc;
  merged := MergeBlockAfter(@committedRoot, b);
  if merged.addr = nil then begin
    result := False;
    exit;
  end;

  if merged.addr < b.addr then begin
    fSize := FillerSizeBeforeGap(b.addr);
    Dec(b.addr, fSize);
    Inc(b.size, fSize);
  end;

  if merged.addr + merged.size > b.addr + b.size then begin
    fSize := FillerSizeAfterGap(b.addr + b.size);
    Inc(b.size, fSize);
  end;

  if merged.addr + merged.size = b.addr + b.size then begin
    FillBeforeGap(b.addr + b.size - sizeof(TUsed), sizeof(TUsed));
    Dec(b.size, sizeof(TUsed));
  end;

  curAlloc := b.addr;
  remBytes := b.size;

  result := True;
end;


function NewCommit(minSize: Integer): Boolean;
var
  b: TBlock;
begin
  b := GetCommitted(minSize+sizeof(TUsed));
  result := (b.addr <> nil) and MergeCommit(b);
end;


function NewCommitAt(addr: Pointer; minSize: Integer): Boolean;
var
  b: TBlock;
begin
  b := GetCommittedAt(addr, minSize+sizeof(TUsed));
  result := (b.addr <> nil) and MergeCommit(b);
end;


function SearchSmallBlocks(size: Integer): PFree;
var
  i: Integer;
begin
  result := nil;
  for i := size div cAlign to High(smallTab^) do begin
    result := smallTab[i];
    if result <> nil then
      exit;
  end;
end;


function TryHarder(size: Integer): Pointer;
var
  u: PUsed; f:PFree; saveSize, rest: Integer;
begin

  repeat

    f := avail.next;
    if (size <= f.size) then
      break;

    f := rover;
    if f.size >= size then
      break;

    saveSize := f.size;
    f.size := size;
    repeat
      f := f.next
    until f.size >= size;
    rover.size := saveSize;
    if f <> rover then begin
      rover := f;
      break;
    end;

    if size <= cSmallSize then begin
      f := SearchSmallBlocks(size);
      if f <> nil then
        break;
    end;

    if not NewCommit(size) then begin
      result := nil;
      exit;
    end;

    if remBytes >= size then begin
      Dec(remBytes, size);
      if remBytes < sizeof(TFree) then begin
        Inc(size, remBytes);
        remBytes := 0;
      end;
      u := PUsed(curAlloc);
      Inc(curAlloc, size);
      u.sizeFlags := size or cThisUsedFlag;
      result := PChar(u) + sizeof(TUsed);
      Inc(AllocMemCount);
      Inc(AllocMemSize,size - sizeof(TUsed));
      exit;
    end;

  until False;

  DeleteFree(f);

  rest := f.size - size;
  if rest >= sizeof(TFree) then begin
    InsertFree(PChar(f) + size, rest);
  end else begin
    size := f.size;
    if f = rover then
      rover := f.next;
    u := PUsed(PChar(f) + size);
    u.sizeFlags := u.sizeFlags and not cPrevFreeFlag;
  end;

  u := PUsed(f);
  u.sizeFlags := size or cThisUsedFlag;

  result := PChar(u) + sizeof(TUsed);
  Inc(AllocMemCount);
  Inc(AllocMemSize,size - sizeof(TUsed));

end;


function SysGetMem(size: Integer): Pointer;
// Allocate memory block.
var
  f, prev, next: PFree;
  u: PUsed;
begin

  if not initialized and not InitAllocator then begin
    result := nil;
    exit;
  end;

  try
    if IsMultiThread then EnterCriticalSection(heapLock);

    Inc(size, sizeof(TUsed) + (cAlign-1));
    size := size and not (cAlign-1);
    if size < sizeof(TFree) then
      size := sizeof(TFree);

    if size <= cSmallSize then begin
      f := smallTab[size div cAlign];
      if f <> nil then begin
        u := PUsed(PChar(f) + size);
        u.sizeFlags := u.sizeFlags and not cPrevFreeFlag;
        next := f.next;
        if next = f then
          smallTab[size div cAlign] := nil
        else begin
          smallTab[size div cAlign] := next;
          prev := f.prev;
          prev.next := next;
          next.prev := prev;
        end;
        u := PUsed(f);
        u.sizeFlags := f.size or cThisUsedFlag;
        result := PChar(u) + sizeof(TUsed);
        Inc(AllocMemCount);
        Inc(AllocMemSize,size - sizeof(TUsed));
        exit;
      end;
    end;

    if size <= remBytes then begin
      Dec(remBytes, size);
      if remBytes < sizeof(TFree) then begin
        Inc(size, remBytes);
        remBytes := 0;
      end;
      u := PUsed(curAlloc);
      Inc(curAlloc, size);
      u.sizeFlags := size or cThisUsedFlag;
      result := PChar(u) + sizeof(TUsed);
      Inc(AllocMemCount);