Inc(AllocMemSize,size - sizeof(TUsed));
      exit;
    end;

    result := TryHarder(size);

  finally
    if IsMultiThread then LeaveCriticalSection(heapLock);
  end;

end;


function SysFreeMem(p: Pointer): Integer;
// Deallocate memory block.
label
  abort;
var
  u, n : PUsed;
  f : PFree;
  prevSize, nextSize, size : Integer;
begin
  heapErrorCode := cHeapOk;

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

  try
    if IsMultiThread then EnterCriticalSection(heapLock);

    u := p;
    u := PUsed(PChar(u) - sizeof(TUsed)); { inv: u = address of allocated block being freed }
    size := u.sizeFlags;
    { inv: size = SET(block size) + [block flags] }

    { validate that the interpretation of this block as a used block is correct }
    if (size and cThisUsedFlag) = 0 then begin
      heapErrorCode := cBadUsedBlock;
      goto abort;
    end;

    { inv: the memory block addressed by 'u' and 'p' is an allocated block }

    Dec(AllocMemCount);
    Dec(AllocMemSize,size and not cFlags - sizeof(TUsed));

    if (size and cPrevFreeFlag) <> 0 then begin
      { previous block is free, coalesce }
      prevSize := PFree(PChar(u)-sizeof(TFree)).size;
      if (prevSize < sizeof(TFree)) or ((prevSize and cFlags) <> 0) then begin
        heapErrorCode := cBadPrevBlock;
        goto abort;
      end;

      f := PFree(PChar(u) - prevSize);
      if f^.size <> prevSize then begin
        heapErrorCode := cBadPrevBlock;
        goto abort;
      end;

      inc(size, prevSize);
      u := PUsed(f);
      DeleteFree(f);
    end;

    size := size and not cFlags;
    { inv: size = block size }

    n := PUsed(PChar(u) + size);
    { inv: n = block following the block to free }

    if PChar(n) = curAlloc then begin
      { inv: u = last block allocated }
      dec(curAlloc, size);
      inc(remBytes, size);
      if remBytes > cDecommitMin then
        FreeCurAlloc;
      result := cHeapOk;
      exit;
    end;

    if (n.sizeFlags and cThisUsedFlag) <> 0 then begin
      { inv: n is a used block }
      if (n.sizeFlags and not cFlags) < sizeof(TUsed) then begin
        heapErrorCode := cBadNextBlock;
        goto abort;
      end;
      n.sizeFlags := n.sizeFlags or cPrevFreeFlag
    end else begin
      { inv: block u & n are both free; coalesce }
      f := PFree(n);
      if (f.next = nil) or (f.prev = nil) or (f.size < sizeof(TFree)) then begin
        heapErrorCode := cBadNextBlock;
        goto abort;
      end;
      nextSize := f.size;
      inc(size, nextSize);
      DeleteFree(f);
      { inv: last block (which was free) is not on free list }
    end;

    InsertFree(u, size);
abort:
    result := heapErrorCode;
  finally
    if IsMultiThread then LeaveCriticalSection(heapLock);
  end;
end;


function ResizeInPlace(p: Pointer; newSize: Integer): Boolean;
var u, n: PUsed; f: PFree; oldSize, blkSize, neededSize: Integer;
begin
  Inc(newSize, sizeof(TUsed)+cAlign-1);
  newSize := newSize and not (cAlign-1);
  if newSize < sizeof(TFree) then
    newSize := sizeof(TFree);
  u := PUsed(PChar(p) - sizeof(TUsed));
  oldSize := u.sizeFlags and not cFlags;
  n := PUsed( PChar(u) + oldSize );
  if newSize <= oldSize then begin
    blkSize := oldSize - newSize;
    if PChar(n) = curAlloc then begin
      Dec(curAlloc, blkSize);
      Inc(remBytes, blkSize);
      if remBytes < sizeof(TFree) then begin
        Inc(curAlloc, blkSize);
        Dec(remBytes, blkSize);
        newSize := oldSize;
      end;
    end else begin
      n := PUsed(PChar(u) + oldSize);
      if n.sizeFlags and cThisUsedFlag = 0 then begin
        f := PFree(n);
        Inc(blkSize, f.size);
        DeleteFree(f);
      end;
      if blkSize >= sizeof(TFree) then begin
        n := PUsed(PChar(u) + newSize);
        n.sizeFlags := blkSize or cThisUsedFlag;
        InternalFreeMem(PChar(n) + sizeof(TUsed));
      end else
        newSize := oldSize;
    end;
  end else begin
    repeat
      neededSize := newSize - oldSize;
      if PChar(n) = curAlloc then begin
        if remBytes >= neededSize then begin
          Dec(remBytes, neededSize);
          Inc(curAlloc, neededSize);
          if remBytes < sizeof(TFree) then begin
            Inc(curAlloc, remBytes);
            Inc(newSize, remBytes);
            remBytes := 0;
          end;
          Inc(AllocMemSize, newSize - oldSize);
          u.sizeFlags := newSize or u.sizeFlags and cFlags;
          result := true;
          exit;
        end else begin
          FreeCurAlloc;
          n := PUsed( PChar(u) + oldSize );
        end;
      end;

      if n.sizeFlags and cThisUsedFlag = 0 then begin
        f := PFree(n);
        blkSize := f.size;
        if blkSize < neededSize then begin
          n := PUsed(PChar(n) + blkSize);
          Dec(neededSize, blkSize);
        end else begin
          DeleteFree(f);
          Dec(blkSize, neededSize);
          if blkSize >= sizeof(TFree) then
            InsertFree(PChar(u) + newSize, blkSize)
          else begin
            Inc(newSize, blkSize);
            n := PUsed(PChar(u) + newSize);
            n.sizeFlags := n.sizeFlags and not cPrevFreeFlag;
          end;
          break;
        end;
      end;

      if n.sizeFlags and cFillerFlag <> 0 then begin
        n := PUsed(PChar(n) + n.sizeFlags and not cFlags);
        if NewCommitAt(n, neededSize) then begin
          n := PUsed( PChar(u) + oldSize );
          continue;
        end;
      end;

      result := False;
      exit;

    until False;

  end;

  Inc(AllocMemSize, newSize - oldSize);
  u.sizeFlags := newSize or u.sizeFlags and cFlags;
  result := True;

end;


function SysReallocMem(p: Pointer; size: Integer): Pointer;
// Resize memory block.
var
  n: Pointer; oldSize: Integer;
begin

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

  try
    if IsMultiThread then EnterCriticalSection(heapLock);

    if ResizeInPlace(p, size) then
      result := p
    else begin
      n := SysGetMem(size);
      oldSize := (PUsed(PChar(p)-sizeof(PUsed)).sizeFlags and not cFlags) - sizeof(TUsed);
      if oldSize > size then
        oldSize := size;
      if n <> nil then begin
        Move(p^, n^, oldSize);
        SysFreeMem(p);
      end;
      result := n;
    end;
  finally
    if IsMultiThread then LeaveCriticalSection(heapLock);
  end;

end;


function BlockSum(root: PBlockDesc): Integer;
var
  b : PBlockDesc;
begin
  result := 0;
  b := root.next;
  while b <> root do begin
    Inc(result, b.size);
    b := b.next;
  end;
end;


function GetHeapStatus: THeapStatus;
var
  size, freeSize, userSize: Cardinal;
  f: PFree;
  a, e: PChar;
  i: Integer;
  b: PBlockDesc;
  prevFree: Boolean;
begin

  heapErrorCode := cHeapOk;

  result.TotalAddrSpace   := 0;
  result.TotalUncommitted := 0;
  result.TotalCommitted   := 0;
  result.TotalAllocated   := 0;
  result.TotalFree        := 0;
  result.FreeSmall        := 0;
  result.FreeBig          := 0;
  result.Unused           := 0;
  result.Overhead         := 0;
  result.HeapErrorCode    := cHeapOk;

  if not initialized then exit;

  try
    if IsMultiThread then EnterCriticalSection(heapLock);

    result.totalAddrSpace   := BlockSum(@spaceRoot);
    result.totalUncommitted := BlockSum(@decommittedRoot);
    result.totalCommitted   := BlockSum(@committedRoot);

    size := 0;
    for i := Low(smallTab^) to High(smallTab^) do begin
      f := smallTab[i];
      if f <> nil then begin
        repeat
          Inc(size, f.size);
          if (f.prev.next <> f) or (f.next.prev <> f) or (f.size < sizeof(TFree)) then begin
            heapErrorCode := cBadFreeList;
            break;
          end;
          f := f.next;
        until f = smallTab[i];
      end;
    end;
    result.freeSmall := size;

    size := 0;
    f := avail.next;
    while f <> @avail do begin
      if (f.prev.next <> f) or (f.next.prev <> f) or (f.size < sizeof(TFree)) then begin
        heapErrorCode := cBadFreeList;
        break;
      end;
      Inc(size, f.size);
      f := f.next;
    end;
    result.freeBig := size;

    result.unused := remBytes;
    result.totalFree := result.freeSmall + result.freeBig + result.unused;

    freeSize := 0;
    userSize := 0;
    result.overhead := 0;

    b := committedRoot.next;
    prevFree := False;
    while b <> @committedRoot do begin
      a := b.addr;
      e := a + b.size;
      while a < e do begin
        if (a = curAlloc) and (remBytes > 0) then begin
          size := remBytes;
          Inc(freeSize, size);
          if prevFree then
            heapErrorCode := cBadCurAlloc;
          prevFree := False;
        end else begin
          if prevFree <> ((PUsed(a).sizeFlags and cPrevFreeFlag) <> 0) then
            heapErrorCode := cBadNextBlock;
          if (PUsed(a).sizeFlags and cThisUsedFlag) = 0 then begin
            f := PFree(a);
            if (f.prev.next <> f) or (f.next.prev <> f) or (f.size < sizeof(TFree)) then
              heapErrorCode := cBadFreeBlock;
            size := f.size;
            Inc(freeSize, size);
            prevFree := True;
          end else begin
            size := PUsed(a).sizeFlags and not cFlags;
            if (PUsed(a).sizeFlags and cFillerFlag) <> 0 then begin
              Inc(result.overhead, size);
              if (a > b.addr) and (a + size < e) then
                heapErrorCode := cBadUsedBlock;
          end else begin
            Inc(userSize, size-sizeof(TUsed));
            Inc(result.overhead, sizeof(TUsed));
          end;
          prevFree := False;
        end;
      end;
      Inc(a, size);
      end;
      b := b.next;
    end;
    if result.totalFree <> freeSize then
      heapErrorCode := cBadBalance;

    result.totalAllocated := userSize;
    result.heapErrorCode := heapErrorCode;
  finally
    if IsMultiThread then LeaveCriticalSection(heapLock);
  end;
end;


//  this section goes into GetMem.Inc

{$IFDEF DEBUG_FUNCTIONS}
type
  THeapReportProc = procedure(HeapBlock: Pointer; AllocatedSize: Integer) of object;


procedure WalkHeap(HeapReportProc: THeapReportProc);
var
  size : Cardinal;
  f: PFree;
  a, e: PChar;
  b: PBlockDesc;
begin

  if not initialized then exit;

  try
    if IsMultiThread then EnterCriticalSection(heapLock);

    b := committedRoot.next;
    while b <> @committedRoot do begin
      a := b.addr;
      e := a + b.size;
      while a < e do begin
        if (a = curAlloc) and (remBytes > 0) then begin
          size := remBytes;
        end else begin
          if (PUsed(a).sizeFlags and cThisUsedFlag) = 0 then begin
            f := PFree(a);
            size := f.size;
          end else begin
            size := PUsed(a).sizeFlags and not cFlags;
            if (PUsed(a).sizeFlags and cFillerFlag) = 0 then begin
              HeapReportProc(a + sizeof(TUsed), size - sizeof(TUsed));
            end;
          end;
        end;
        Inc(a, size);
      end;
      b := b.next;
    end;
  finally
    if IsMultiThread then LeaveCriticalSection(heapLock);
  end;
end;

type
  THeapBlockCollector = class(TObject)
    FCount: Integer;
    FObjectTable: TObjectArray;
    FHeapBlockTable: THeapBlockArray;
    FClass: TClass;
    FFindDerived: Boolean;
    procedure CollectBlocks(HeapBlock: Pointer; AllocatedSize: Integer);
    procedure CollectObjects(HeapBlock: Pointer; AllocatedSize: Integer);
  end;


procedure THeapBlockCollector.CollectBlocks(HeapBlock: Pointer; AllocatedSize: Integer);
begin
  if FCount < Length(FHeapBlockTable) then
  begin
    FHeapBlockTable[FCount].Start := HeapBlock;
    FHeapBlockTable[FCount].Size  := AllocatedSize;
  end;
  Inc(FCount);
end;


procedure THeapBlockCollector.CollectObjects(HeapBlock: Pointer; AllocatedSize: Integer);
var
  AObject: TObject;
  AClass: TClass;
type
  PPointer = ^Pointer;
begin
  try
    if AllocatedSize < 4 then
      Exit;
    AObject := TObject(HeapBlock);
    AClass := AObject.ClassType;
    if (AClass = FClass)
      or (FFindDerived
        and (Integer(AClass) >= 64*1024)
        and (PPointer(PChar(AClass) + vmtSelfPtr)^ = Pointer(AClass))
        and (AObject is FClass)) then
    begin
      if FCount < Length(FObjectTable) then
        FObjectTable[FCount] := AObject;
      Inc(FCount);
    end;
  except
  //  Let's not worry about this block - it's obviously not a valid object
  end;
end;

var
  HeapBlockCollector: THeapBlockCollector;

function GetHeapBlocks: THeapBlockArray;
begin
  if not Assigned(HeapBlockCollector) then
    HeapBlockCollector := THeapBlockCollector.Create;

  Walkheap(HeapBlockCollector.CollectBlocks);
  SetLength(HeapBlockCollector.FHeapBlockTable, HeapBlockCollector.FCount);
  HeapBlockCollector.FCount := 0;
  Walkheap(HeapBlockCollector.CollectBlocks);
  Result := HeapBlockCollector.FHeapBlockTable;
  HeapBlockCollector.FCount := 0;
  HeapBlockCollector.FHeapBlockTable := nil;
end;


function FindObjects(AClass: TClass; FindDerived: Boolean): TObjectArray;
begin
  if not Assigned(HeapBlockCollector) then
    HeapBlockCollector := THeapBlockCollector.Create;
  HeapBlockCollector.FClass := AClass;
  HeapBlockCollector.FFindDerived := FindDerived;

  Walkheap(HeapBlockCollector.CollectObjects);
  SetLength(HeapBlockCollector.FObjectTable, HeapBlockCollector.FCount);
  HeapBlockCollector.FCount := 0;
  Walkheap(HeapBlockCollector.CollectObjects);
  Result := HeapBlockCollector.FObjectTable;
  HeapBlockCollector.FCount := 0;
  HeapBlockCollector.FObjectTable := nil;
end;
{$ENDIF}