unit dstackallocator;

{$MODE FPC}
{$MODESWITCH ADVANCEDRECORDS}
{$MODESWITCH DEFAULTPARAMETERS}
{$MODESWITCH OUT}
{$MODESWITCH RESULT}

interface

type
PStackAllocator = ^TStackAllocator;
TStackAllocator = record
public const
  PAGE_SIZE = 1024 * 1024;
public type
  PPage = ^TPage;
  TPage = record
  private
    Prev: PPage;
    Buffer: array[0 .. PAGE_SIZE - 1] of Byte;
  end;
private
  Cur: Pointer;
  BufEnd: Pointer;
  PageSize: SizeUInt;
  Page: PPage;
  LastPtr: Pointer;
  LastSize: SizeUInt;
end;

procedure saInit(var Stack: TStackAllocator; PageSize: SizeUInt = TStackAllocator.PAGE_SIZE);
procedure saDone(var Stack: TStackAllocator);
function saGetMem(var Stack: TStackAllocator; Size: SizeUInt): Pointer;
procedure saFreeMem(var Stack: TStackAllocator; Ptr: Pointer);

implementation

procedure saInit(var Stack: TStackAllocator; PageSize: SizeUInt = TStackAllocator.PAGE_SIZE);
begin
  Stack.Cur := nil;
  Stack.BufEnd := nil;
  Stack.PageSize := PageSize;
  Stack.Page := nil;
  Stack.LastPtr := nil;
  Stack.LastSize := 0;
end;

procedure saDone(var Stack: TStackAllocator);
var
  Page, Next: TStackAllocator.PPage;
begin
  Page := Stack.Page;
  while Page <> nil do begin
    Next := Page^.Prev;
    FreeMem(Page);
    Page := Next;
  end;
  Stack.Page := nil;
end;

function saGetMem(var Stack: TStackAllocator; Size: SizeUInt): Pointer;
var
  Page: TStackAllocator.PPage;
begin
  if Size > Stack.BufEnd - Stack.Cur then begin
    if Size > TStackAllocator.PAGE_SIZE then begin
      Page := GetMem(Size + SizeOf(TStackAllocator.PPage));
      Result := @Page^.Buffer[0];
      if Stack.Page <> nil then begin
        Page^.Prev := Stack.Page^.Prev;
        Stack.Page^.Prev := Page;
      end else begin
        Page^.Prev := nil;
        Stack.Page := Page;
      end;
      Exit;
    end;
    Page := GetMem(SizeOf(TStackAllocator.TPage));
    Page^.Prev := Stack.Page;
    Stack.Page := Page;
    Stack.Cur := @Page^.Buffer[0];
    Stack.BufEnd := @Page^.Buffer[0] + TStackAllocator.PAGE_SIZE;
  end;
  Result := Stack.Cur;
  Inc(Stack.Cur, Size);
  Stack.LastPtr := Result;
  Stack.LastSize := Size;
end;

procedure saFreeMem(var Stack: TStackAllocator; Ptr: Pointer);
begin
  if Ptr = Stack.LastPtr then begin
    Dec(Stack.Cur, Stack.LastSize);
  end;
end;

end.
