// Three layers:
// - Address space administration
// - Committed space administration
// - Suballocator
//
// Helper module: administrating block descriptors
//


//
// Operating system interface
//
const
  LMEM_FIXED = 0;
  LMEM_ZEROINIT = $40;

  MEM_COMMIT   = $1000;
  MEM_RESERVE  = $2000;
  MEM_DECOMMIT = $4000;
  MEM_RELEASE  = $8000;

  PAGE_NOACCESS  = 1;
  PAGE_READWRITE = 4;

type
  DWORD = Integer;
  BOOL  = LongBool;

  TRTLCriticalSection = packed record
    DebugInfo: Pointer;
    LockCount: Longint;
    RecursionCount: Longint;
    OwningThread: Integer;
    LockSemaphore: Integer;
    Reserved: DWORD;
  end;

function LocalAlloc(flags, size: Integer): Pointer; stdcall;
  external kernel name 'LocalAlloc';
function LocalFree(addr: Pointer): Pointer; stdcall;
  external kernel name 'LocalFree';

function VirtualAlloc(lpAddress: Pointer;
  dwSize, flAllocationType, flProtect: DWORD): Pointer; stdcall;
  external kernel name 'VirtualAlloc';
function VirtualFree(lpAddress: Pointer; dwSize, dwFreeType: DWORD): BOOL; stdcall;
  external kernel name 'VirtualFree';

procedure InitializeCriticalSection(var lpCriticalSection: TRTLCriticalSection); stdcall;
  external kernel name 'InitializeCriticalSection';
procedure EnterCriticalSection(var lpCriticalSection: TRTLCriticalSection); stdcall;
  external kernel name 'EnterCriticalSection';
procedure LeaveCriticalSection(var lpCriticalSection: TRTLCriticalSection); stdcall;
  external kernel name 'LeaveCriticalSection';
procedure DeleteCriticalSection(var lpCriticalSection: TRTLCriticalSection); stdcall;
  external kernel name 'DeleteCriticalSection';

// Common Data structure:

type
  TBlock = packed record
    addr: PChar;
    size: Integer;
  end;

// Heap error codes

const
  cHeapOk           = 0;          // everything's fine
  cReleaseErr       = 1;          // operating system returned an error when we released
  cDecommitErr      = 2;          // operating system returned an error when we decommited
  cBadCommittedList = 3;          // list of committed blocks looks bad
  cBadFiller1       = 4;          // filler block is bad
  cBadFiller2       = 5;          // filler block is bad
  cBadFiller3       = 6;          // filler block is bad
  cBadCurAlloc      = 7;          // current allocation zone is bad
  cCantInit         = 8;          // couldn't initialize
  cBadUsedBlock     = 9;          // used block looks bad
  cBadPrevBlock     = 10;         // prev block before a used block is bad
  cBadNextBlock     = 11;         // next block after a used block is bad
  cBadFreeList      = 12;         // free list is bad
  cBadFreeBlock     = 13;         // free block is bad
  cBadBalance       = 14;         // free list doesn't correspond to blocks marked free

var
  initialized   : Boolean;
  heapErrorCode : Integer;
  heapLock      : TRTLCriticalSection;

//
// Helper module: administrating block descriptors.
//
type
  PBlockDesc = ^TBlockDesc;
  TBlockDesc = packed record
    next: PBlockDesc;
    prev: PBlockDesc;
    addr: PChar;
    size: Integer;
  end;

type
  PBlockDescBlock = ^TBlockDescBlock;
  TBlockDescBlock = packed record
    next: PBlockDescBlock;
    data: array [0..99] of TBlockDesc;
  end;

var
  blockDescBlockList: PBlockDescBlock;
  blockDescFreeList : PBlockDesc;


function GetBlockDesc: PBlockDesc;
// Get a block descriptor.
// Will return nil for failure.
var
  bd:  PBlockDesc;
  bdb: PBlockDescBlock;
  i:   Integer;
begin
  if blockDescFreeList = nil then begin
    bdb := LocalAlloc(LMEM_FIXED, sizeof(bdb^));
    if bdb = nil then begin
      result := nil;
      exit;
    end;
    bdb.next := blockDescBlockList;
    blockDescBlockList := bdb;
    for i := low(bdb.data) to high(bdb.data) do begin
      bd := @bdb.data[i];
      bd.next := blockDescFreeList;
      blockDescFreeList := bd;
    end;
  end;
  bd := blockDescFreeList;
  blockDescFreeList := bd.next;
  result := bd;
end;


procedure MakeEmpty(bd: PBlockDesc);
begin
  bd.next := bd;
  bd.prev := bd;
end;


function AddBlockAfter(prev: PBlockDesc; const b: TBlock): Boolean;
var
  next, bd: PBlockDesc;
begin
  bd := GetBlockDesc;
  if bd = nil then
    result := False
  else begin
    bd.addr := b.addr;
    bd.size := b.size;

    next := prev.next;
    bd.next := next;
    bd.prev := prev;
    next.prev := bd;
    prev.next := bd;

    result := True;
  end;
end;


procedure DeleteBlock(bd: PBlockDesc);
var
  prev, next: PBlockDesc;
begin
  prev := bd.prev;
  next := bd.next;
  prev.next := next;
  next.prev := prev;
  bd.next := blockDescFreeList;
  blockDescFreeList := bd;
end;


function MergeBlockAfter(prev: PBlockDesc; const b: TBlock) : TBlock;
var
  bd, bdNext: PBlockDesc;
begin
  bd := prev.next;
  result := b;
  repeat
    bdNext := bd.next;
    if bd.addr + bd.size = result.addr then begin
      DeleteBlock(bd);
      result.addr := bd.addr;
      inc(result.size, bd.size);
    end else if result.addr + result.size = bd.addr then begin
      DeleteBlock(bd);
      inc(result.size, bd.size);
    end;
    bd := bdNext;
  until bd = prev;
  if not AddBlockAfter(prev, result) then
    result.addr := nil;
end;


function RemoveBlock(bd: PBlockDesc; const b: TBlock): Boolean;
var
  n: TBlock;
  start: PBlockDesc;
begin
  start := bd;
  repeat
    if (bd.addr <= b.addr) and (bd.addr + bd.size >= b.addr + b.size) then begin
      if bd.addr = b.addr then begin
        Inc(bd.addr, b.size);
        Dec(bd.size, b.size);
        if bd.size = 0 then
          DeleteBlock(bd);
      end else if bd.addr + bd.size = b.addr + b.size then
        Dec(bd.size, b.size)
      else begin
        n.addr := b.addr + b.size;
        n.size := bd.addr + bd.size - n.addr;
        bd.size := b.addr - bd.addr;
        if not AddBlockAfter(bd, n) then begin
          result := False;
          exit;
        end;
      end;
      result := True;
      exit;
    end;
    bd := bd.next;
  until bd = start;
  result := False;
end;



//
// Address space administration:
//

const
  cSpaceAlign = 64*1024;
  cSpaceMin   = 1024*1024;
  cPageAlign  = 4*1024;

var
  spaceRoot: TBlockDesc;


function GetSpace(minSize: Integer): TBlock;
// Get at least minSize bytes address space.
// Success: returns a block, possibly much bigger than requested.
// Will not fail - will raise an exception or terminate program.
begin
  if minSize < cSpaceMin then
    minSize := cSpaceMin
  else
    minSize := (minSize + (cSpaceAlign-1)) and not (cSpaceAlign-1);

  result.size := minSize;
  result.addr := VirtualAlloc(nil, minSize, MEM_RESERVE, PAGE_NOACCESS);
  if result.addr = nil then
    exit;

  if not AddBlockAfter(@spaceRoot, result) then begin
    VirtualFree(result.addr, 0, MEM_RELEASE);
    result.addr := nil;
    exit;
  end;
end;


function GetSpaceAt(addr: PChar; minSize: Integer): TBlock;
// Get at least minSize bytes address space at addr.
// Return values as above.
// Failure: returns block with addr = nil.
begin
  result.size := cSpaceMin;
  result.addr := VirtualAlloc(addr, cSpaceMin, MEM_RESERVE, PAGE_READWRITE);
  if result.addr = nil then begin
    minSize := (minSize + (cSpaceAlign-1)) and not (cSpaceAlign-1);
    result.size := minSize;
    result.addr := VirtualAlloc(addr, minSize, MEM_RESERVE, PAGE_READWRITE);
  end;
  if result.addr <> nil then begin
    if not AddBlockAfter(@spaceRoot, result) then begin
      VirtualFree(result.addr, 0, MEM_RELEASE);
      result.addr := nil;
    end;
  end;
end;


function FreeSpace(addr: Pointer; maxSize: Integer): TBlock;
// Free at most maxSize bytes of address space at addr.
// Returns the block that was actually freed.
var
  bd, bdNext: PBlockDesc;
  minAddr, maxAddr, startAddr, endAddr: PChar;
begin
  minAddr := PChar($FFFFFFFF);
  maxAddr := nil;
  startAddr := addr;
  endAddr   := startAddr + maxSize;
  bd := spaceRoot.next;
  while bd <> @spaceRoot do begin
    bdNext := bd.next;
    if (bd.addr >= startAddr) and (bd.addr + bd.size <= endAddr) then begin
      if minAddr > bd.addr then
        minAddr := bd.addr;
      if maxAddr < bd.addr + bd.size then
        maxAddr := bd.addr + bd.size;
      if not VirtualFree(bd.addr, 0, MEM_RELEASE) then
        heapErrorCode := cReleaseErr;
      DeleteBlock(bd);
    end;
    bd := bdNext;
  end;
  result.addr := nil;
  if maxAddr <> nil then begin
    result.addr := minAddr;
    result.size := maxAddr - minAddr;
  end;
end;


function Commit(addr: Pointer; minSize: Integer): TBlock;
// Commits memory.
// Returns the block that was actually committed.
// Will return a block with addr = nil on failure.
var
  bd: PBlockDesc;
  loAddr, hiAddr, startAddr, endAddr: PChar;
begin
  startAddr := PChar(Integer(addr) and not (cPageAlign-1));
  endAddr := PChar(((Integer(addr) + minSize) + (cPageAlign-1)) and not (cPageAlign-1));
  result.addr := startAddr;
  result.size := endAddr - startAddr;
  bd := spaceRoot.next;
  while bd <> @spaceRoot do begin
    // Commit the intersection of the block described by bd and [startAddr..endAddr)
    loAddr := bd.addr;
    hiAddr := loAddr + bd.size;
    if loAddr < startAddr then
      loAddr := startAddr;
    if hiAddr > endAddr then
      hiAddr := endAddr;
    if loAddr < hiAddr then begin
      if VirtualAlloc(loAddr, hiAddr - loAddr, MEM_COMMIT, PAGE_READWRITE) = nil then begin
        result.addr := nil;
        exit;
      end;
    end;
    bd := bd.next;
  end;
end;


function Decommit(addr: Pointer; maxSize: Integer): TBlock;
// Decommits address space.
// Returns the block that was actually decommitted.
var
  bd: PBlockDesc;
  loAddr, hiAddr, startAddr, endAddr: PChar;
begin
  startAddr := PChar((Integer(addr) + + (cPageAlign-1)) and not (cPageAlign-1));
  endAddr := PChar((Integer(addr) + maxSize) and not (cPageAlign-1));
  result.addr := startAddr;
  result.size := endAddr - startAddr;
  bd := spaceRoot.next;
  while bd <> @spaceRoot do begin
    // Decommit the intersection of the block described by bd and [startAddr..endAddr)
    loAddr := bd.addr;
    hiAddr := loAddr + bd.size;
    if loAddr < startAddr then
      loAddr := startAddr;
    if hiAddr > endAddr then
      hiAddr := endAddr;
    if loAddr < hiAddr then begin
      if not VirtualFree(loAddr, hiAddr - loAddr, MEM_DECOMMIT) then
        heapErrorCode := cDecommitErr;
    end;
    bd := bd.next;
  end;
end;


//
// Committed space administration
//
const
  cCommitAlign = 16*1024;

var
  decommittedRoot: TBlockDesc;


function GetCommitted(minSize: Integer): TBlock;
// Get a block of committed memory.
// Returns a committed memory block, possibly much bigger than requested.
// Will return a block with a nil addr on failure.
var
  bd: PBlockDesc;
begin
  minSize := (minSize + (cCommitAlign-1)) and not (cCommitAlign-1);
  repeat
    bd := decommittedRoot.next;
    while bd <> @decommittedRoot do begin
      if bd.size >= minSize then begin
        result := Commit(bd.addr, minSize);
        if result.addr = nil then
          exit;
        Inc(bd.addr, result.size);
        Dec(bd.size, result.size);
        if bd.size = 0 then
          DeleteBlock(bd);
        exit;
      end;
      bd := bd.next;
    end;
    result := GetSpace(minSize);
    if result.addr = nil then
      exit;
    if MergeBlockAfter(@decommittedRoot, result).addr = nil then begin
      FreeSpace(result.addr, result.size);
      result.addr := nil;
      exit;
    end;
  until False;
end;


function GetCommittedAt(addr: PChar; minSize: Integer): TBlock;
// Get at least minSize bytes committed space at addr.
// Success: returns a block, possibly much bigger than requested.
// Failure: returns a block with addr = nil.
var
  bd: PBlockDesc;
  b: TBlock;
begin
  minSize := (minSize + (cCommitAlign-1)) and not (cCommitAlign-1);
  repeat

    bd := decommittedRoot.next;
    while (bd <> @decommittedRoot) and (bd.addr <> addr) do
      bd := bd.next;

    if bd.addr = addr then begin
      if bd.size >= minSize then
        break;
      b := GetSpaceAt(bd.addr + bd.size, minSize - bd.size);
      if b.addr <> nil then begin
        if MergeBlockAfter(@decommittedRoot, b).addr <> nil then
          continue
        else begin
          FreeSpace(b.addr, b.size);
          result.addr := nil;
          exit;
        end;
      end;
    end;

    b := GetSpaceAt(addr, minSize);
    if b.addr = nil then
      break;

    if MergeBlockAfter(@decommittedRoot, b).addr = nil then begin
      FreeSpace(b.addr, b.size);
      result.addr := nil;
      exit;
    end;
  until false;

  if (bd.addr = addr) and (bd.size >= minSize) then begin
    result := Commit(bd.addr, minSize);
    if result.addr = nil then
      exit;
    Inc(bd.addr, result.size);
    Dec(bd.size, result.size);
    if bd.size = 0 then
      DeleteBlock(bd);
  end else
    result.addr := nil;
end;


function FreeCommitted(addr: PChar; maxSize: Integer): TBlock;
// Free at most maxSize bytes of address space at addr.
// Returns the block that was actually freed.
var
  startAddr, endAddr: PChar;
  b: TBlock;
begin
  startAddr := PChar(Integer(addr + (cCommitAlign-1)) and not (cCommitAlign-1));
  endAddr := PChar(Integer(addr + maxSize) and not (cCommitAlign-1));
  if endAddr > startAddr then begin
    result := Decommit(startAddr, endAddr - startAddr);
    b := MergeBlockAfter(@decommittedRoot, result);
    if b.addr <> nil then
      b := FreeSpace(b.addr, b.size);
    if b.addr <> nil then
      RemoveBlock(@decommittedRoot, b);
  end else
    result.addr := nil;
end;