{$MODE OBJFPC}
unit dpool;

interface

type
TPoolDefaultStaticInfo = object
public const
  PAGE_SIZE = 128; // 128 values per page
  STATIC_SIZE = 64 * 1024; // 64KB static size;
end;

// TValueContainer must contain readable/writable field Next
// Example:
//   TValueContainer = packed record
//     Value: TValue;
//     Next: PValueContainer;
//   end;
// But instead you can pass value itself with field Next for typical usage
generic TPool<TValueContainer, TStaticInfo> = object
public type
  TPtr = ^TPool;
  PValueContainer = ^TValueContainer;
  PPage = ^TPage; 
  TPage = packed record
    Prev: PPage;
    Start: PValueContainer;
    Count: LongInt; // count of all values in Block
    Index: LongInt; // current not-allocated container
  end;
private
  FPage: TPage;
  FStatic: array[0 .. TStaticInfo.STATIC_SIZE div SizeOf(TValueContainer) - 1] of TValueContainer;
  FFirstFree: PValueContainer;
  procedure NewPage;
public
  procedure Init; inline;
  procedure Done;
  function Alloc: PValueContainer; inline;
  procedure Dealloc(Value: PValueContainer); inline;
public // Utils
  type
    PStatistics = ^TStatistics;
    TStatistics = record
      Pages: LongInt;
      Size: Int64; // all size in bytes
      Count: Int64; // all values in pool (alloced and not)
      AllocedCount: Int64; // number of alloced values
      SemiInitialized: Int64; // semi-initialized objects in pool
      NotInitialized: Int64; // not-initialized objects
    end;
  procedure ComputeStatistics(Statistics: PStatistics);
public
// Do not use it if you don't know what you are doing (see an example in uber3
// framework).
  type
    TForValue = procedure (Value: PValueContainer);
  // returns True if returned Value is not semi-initialized
  function Alloc(var Value: PValueContainer): Boolean;
  procedure DoForEachSemiInitialized(Proc: TForValue);
end;

implementation

procedure TPool.NewPage;
var
  P: PPage;
begin
  New(P);
  P^ := FPage;
  FPage.Prev := P;
  FPage.Start := GetMem(SizeOf(TValueContainer) * TStaticInfo.PAGE_SIZE);
  FPage.Count := TStaticInfo.PAGE_SIZE;
  FPage.Index := 0;
end;

procedure TPool.Init;
begin
  FPage.Prev := nil;
  FPage.Start := @FStatic;
  FPage.Count := TStaticInfo.STATIC_SIZE div SizeOf(TValueContainer);
  FPage.Index := 0;
  FFirstFree := nil;
end;

procedure TPool.Done;
var
  F, P: PPage;
  S: PValueContainer;
begin
  P := @FPage;
  F := FPage.Prev;
  S := P^.Start;
  while F <> nil do begin
    FreeMem(Pointer(S));
    P := F;
    F := P^.Prev;
    S := P^.Start;
    Dispose(P);
  end;
end;

function TPool.Alloc: PValueContainer;
begin
  Alloc(Result);
end;

procedure TPool.Dealloc(Value: PValueContainer);
begin
  PValueContainer(Value)^.Next := FFirstFree;
  FFirstFree := PValueContainer(Value);
end;

procedure TPool.ComputeStatistics(Statistics: PStatistics);
var
  P: PPage;
  It: PValueContainer;
begin
  Statistics^.Pages := 0;
  Statistics^.Size := 0;
  Statistics^.Count := 0;
  Statistics^.SemiInitialized := 0;
  Statistics^.NotInitialized := 0;
  P := @FPage;
  while P <> nil do begin
    Inc(Statistics^.Pages);
    Inc(Statistics^.Size, SizeOf(TPage) + P^.Count * SizeOf(TValueContainer));
    Inc(Statistics^.Count, P^.Count);
    Inc(Statistics^.NotInitialized, P^.Count - P^.Index);
    P := P^.Prev;
  end;
  It := FFirstFree;
  while It <> nil do begin
    Inc(Statistics^.SemiInitialized);
    It := It^.Next;
  end;
  Statistics^.AllocedCount := Statistics^.Count - Statistics^.NotInitialized - Statistics^.SemiInitialized;
end;

function TPool.Alloc(var Value: PValueContainer): Boolean;
begin
  if FFirstFree <> nil then begin
    Value := FFirstFree;
    FFirstFree := FFirstFree^.Next;
    Exit(False);
  end;
  if FPage.Index >= FPage.Count then
    NewPage;
  Value := @FPage.Start[FPage.Index];
  Inc(FPage.Index);
  Exit(True);
end;

procedure TPool.DoForEachSemiInitialized(Proc: TForValue);
var
  It: PValueContainer;
begin
  It := FFirstFree;
  while It <> nil do begin
    Proc(It);
    It := It^.Next;
  end;
end;

end.
