unit vstack;
{$IFDEF FPC}
  {$MODE DELPHI}{$H+}
{$ENDIF}

(***************************************)
(* Copyright (C) 2003, SHIRAISHI Kazuo *)
(***************************************)


interface
uses
    base;

function getmemory(size:NativeInt):pointer;
function GetZeroMemory(size:NativeInt):pointer;
procedure freememory(size:NativeInt);
procedure InitMemory;
procedure InitVirtualStack(size:NativeUInt);
procedure DiscardVirtualStack;

implementation
uses
 {$IFDEF windows}Windows;{$ENDIF}
 {$IFDEF Unix} BaseUnix, Unix, UnixType;{$ENDIF}


var
  StackBase :   pointer;
  StackBottom : pointer;
  StackLimit :  pointer;
  MaxStackSize :   NativeUInt;
  StackSize :      NativeUInt = 0;

{$ASMMODE intel}
{$IFDEF CPUX86_64}
procedure clear(var a; n:Int64);assembler;
asm
   push   rdi
   mov    rdi,a
   mov    rcx,n
   shr    rcx,3
   xor    rax,rax
   rep    stosq
   pop    rdi
end;
{$ELSE}  {i386 32bit}
procedure clear(var a; n:Integer);assembler;
asm
   push   edi
   mov    edi,a
   mov    ecx,n
   shr    ecx,2
   xor    eax,eax
   rep    stosd
   pop    edi
end;
{$ENDIF}


{$IFDEF Windows}

const StackDelta  =  $10000; // 64Kbytes

function intraise(i:NativeUInt):NativeUInt;
begin
    if i mod StackDelta =0 then
      result:=i
    else
      result:=((i div StackDelta)+1)*StackDelta
end;

procedure enlarge(size:NativeInt);
var
    temp:NativeUInt;
    temp1:pointer;
begin
    temp:=StackSize+intraise(size);
    temp1:=VirtualAlloc(StackBase,temp,
                                       MEM_COMMIT,PAGE_READWRITE);
    if temp1=nil then
          begin
             temp1:=VirtualAlloc(StackBase,StackSize,
                                       MEM_COMMIT,PAGE_READWRITE);
             setexception(VirtualStackOverflow);
          end;
    StackSize:=temp;
    StackBase:=temp1;
    //NativeUInt(StackLimit):=NativeUInt(StackBase)+StackSize;
    StackLimit:=StackBase;
    Inc(StackLimit,StackSize);
end;

function getmemory(size:NativeInt):pointer;
begin
  if NativeUInt(StackLimit)-NativeUInt(StackBottom)<size then
     enlarge(size);
  GetMemory:=StackBottom;
  Inc(StackBottom,size);
end;

function GetZeroMemory(size:NativeInt):pointer;
begin
  if NativeUInt(StackLimit)-NativeUInt(StackBottom)<size then
     enlarge(size);
  clear(StackBottom^, size);
  GetZeroMemory:=StackBottom;
  Inc(StackBottom,size);
end;

procedure freememory(size:NativeInt);
begin
  Dec(StackBottom,size);
  if StackBottom<StackBase then
                               setexception(-107)
end;

procedure InitMemory;
begin
  StackBottom:=StackBase
end;


procedure InitVirtualStack(size:NativeUInt);
begin
  MaxStackSize:=size;
  StackBase:=VirtualAlloc(nil,MaxStackSize,MEM_RESERVE {$IFDEF CPU32}+ MEM_TOP_DOWN{$ENDIF},PAGE_READWRITE);
  {
  while StackBase=nil do
    begin
      Dec(NativeUInt(MaxStackSize),$1000000);
      StackBase:=VirtualAlloc(nil,MaxStackSize,MEM_RESERVE + MEM_TOP_DOWN,PAGE_READWRITE);
    end;}
  if StackBase=nil then
       SetException(TooLargeVirtualStack);

  StackBottom:=StackBase;
  StackLimit:=StackBase;
end;

procedure DiscardVirtualStack;
begin
   VirtualFree(StackBase,MaxStackSize,MEM_DECOMMIT);
   VirtualFree(StackBase,0,MEM_RELEASE);
end;



{$ELSE}


function getmemory(size:NativeInt):pointer;
begin
  if NativeInt(StackLimit)-NativeInt(StackBottom)<size then
                   setexception(VirtualStackOverflow);
  GetMemory:=StackBottom;
  inc(StackBottom,size);
end;

function GetZeroMemory(size:NativeInt):pointer;
begin
  if NativeInt(StackLimit)-NativeInt(StackBottom)<size then
                   setexception(VirtualStackOverflow);
  clear(StackBottom^, size);
  GetZeroMemory:=StackBottom;
  inc(StackBottom,size);
end;


procedure freememory(size:NativeInt);
begin
  dec(StackBottom,size);
end;

procedure InitMemory;
begin
  StackBottom:=StackBase
end;



procedure InitializeStackBase;
{$IFDEF Unix}
begin
 StackBase:=fpmmap(nil, StackSize, PROT_READ or PROT_WRITE
                  , MAP_PRIVATE or MAP_ANONYMOUS, 0, 0);
 (*
 while StackBase=MAP_FAILED do
    begin
       dec(StackSize, $4000000{64MB});
       StackBase:=fpmmap(nil, StackSize, PROT_READ or PROT_WRITE
                          , MAP_PRIVATE or MAP_ANONYMOUS, 0, 0);
    end;
 *)
  if StackBase=MAP_FAILED then
     SetException(TooLargeVirtualStack);
end;
{$ELSE}
begin
   try
     GetMem(StackBase,StackSize);
   except
     SetException(TooLargeVirtualStack);
   end;
end;
{$ENDIF}

procedure InitVirtualStack(size:NativeUInt);
begin
 stacksize:=size;
 InitializeStackBase;
 StackBottom:=StackBase;
 StackLimit:=StackBase;
 Inc(StackLimit,StackSize);
end;


procedure DiscardVirtualStack;
begin
{$IFDEF Unix}
   fpmunmap(StackBase,StackSize);
{$ELSE}
    FreeMem(stackBase,StackSize);
{$ENDIF}
end;

{$ENDIF}
initialization


finalization


end.
