unit xprCompiler;
{
  Author: Jarl K. Holta
  License: GNU Lesser GPL (http://www.gnu.org/licenses/lgpl.html)
}
{$I header.inc}
{$hints off}

interface

uses
  SysUtils, xprTypes, xprBytecode, xprErrors,
  Windows;

type
  // static register-stack for performance and simplicty
  // in the future we might find this size to be limiting
  TRegister64k = array [0..$FFFF] of record
    case Byte of
      1: (b: Boolean;);
      2: (f: Double;);
      3: (i: Int64; );
      4: (r: array[0..7] of byte; );
  end;

  TStackPointer = array [0..$3FF] of SizeInt;

  TNativeCompiler = record
    Bytecode: TByteCode;

    FProgram: Pointer;
    FRegisters: TRegister64k;

    // stack pointer or a perhaps rather a register pointer
    // disallow inf recursion, limited to 1K atm.
    FSPStack: TStackPointer;
    FSPSize: Int32;
    FSP: ^SizeInt;

    function Get_MUL_Code(const Op: TInstruction): TBytes;
    function Get_EQ_Code(const Op: TInstruction): TBytes;
    function Get_LTE_Code(const Op: TInstruction): TBytes;
    function Get_ASGN_Code(const Op: TInstruction): TBytes;
    function Get_LADD_Code(const Op: TInstruction): TBytes;
    function Get_LSUB_Code(const Op: TInstruction): TBytes;

    procedure PrepRegisters();
    procedure LoadConstants(C: TConstantList);
    function MakeExecutable(Code: TBytes; Size: Int32): TInstruction;
    function Compile(BC: TByteCode): TByteCode;
  end;


implementation

uses
  Math;


{$DEFINE COPY_CODE_BINARY :=
  if Op.Args[1].Typ in XprFloatTypes then
  begin
    Result := GetCode(@f_stack_stack, @body)
  end else
  begin
    Result := GetCode(@i_stack_stack, @f_stack_stack)
  end
}

{$DEFINE COPY_CODE_ASSIGN :=
  if Op.Args[1].Typ in XprFloatTypes then
  begin
    Result := GetCode(@f_stack_stack, @body)
  end else
  begin
    Result := GetCode(@i_stack_stack, @f_stack_stack)
  end
}

function GetCode(start, stop: Pointer): TBytes;
var sz: SizeInt;
begin
  sz := PtrUInt(stop) - PtrUInt(start);
  SetLength(Result, sz);
  Move(start^, Result[0], sz);
end;

function TNativeCompiler.Get_MUL_Code(const Op: TInstruction): TBytes;
label i_stack_stack, f_stack_stack, body;
begin
  goto body;
  i_stack_stack: FRegisters[FSP^ + Op.Args[2].Arg].i := FRegisters[FSP^ + Op.Args[0].Arg].i * FRegisters[FSP^ + Op.Args[1].Arg].i;
  f_stack_stack: FRegisters[FSP^ + Op.Args[2].Arg].f := FRegisters[FSP^ + Op.Args[0].Arg].f * FRegisters[FSP^ + Op.Args[1].Arg].f;
  // handle globals where stackptr is 0, not needed for limited test.
  body:
  COPY_CODE_BINARY;
end;


function TNativeCompiler.Get_EQ_Code(const Op: TInstruction): TBytes;
label i_stack_stack, f_stack_stack, body;
begin
  goto body;
  i_stack_stack: FRegisters[FSP^ + Op.Args[2].Arg].b := FRegisters[FSP^ + Op.Args[0].Arg].i = FRegisters[FSP^ + Op.Args[1].Arg].i;
  f_stack_stack: FRegisters[FSP^ + Op.Args[2].Arg].b := FRegisters[FSP^ + Op.Args[0].Arg].f = FRegisters[FSP^ + Op.Args[1].Arg].f;
  // handle globals where stackptr is 0, not needed for limited test.
  body:
  COPY_CODE_BINARY;
end;

function TNativeCompiler.Get_LTE_Code(const Op: TInstruction): TBytes;
label i_stack_stack, f_stack_stack, body;
begin
  goto body;
  i_stack_stack: FRegisters[FSP^ + Op.Args[2].Arg].b := FRegisters[FSP^ + Op.Args[0].Arg].i <= FRegisters[FSP^ + Op.Args[1].Arg].i;
  f_stack_stack: FRegisters[FSP^ + Op.Args[2].Arg].b := FRegisters[FSP^ + Op.Args[0].Arg].f <= FRegisters[FSP^ + Op.Args[1].Arg].f;
  // handle globals where stackptr is 0, not needed for limited test.
  body:
  COPY_CODE_BINARY;
end;


function TNativeCompiler.Get_ASGN_Code(const Op: TInstruction): TBytes;
label i_stack_stack, f_stack_stack, body;
begin
  goto body;
  i_stack_stack: FRegisters[FSP^ + Op.Args[0].Arg].i := FRegisters[FSP^ + Op.Args[1].Arg].i;
  f_stack_stack: FRegisters[FSP^ + Op.Args[0].Arg].f := FRegisters[FSP^ + Op.Args[1].Arg].f;
  // handle globals where stackptr is 0, not needed for limited test.
  body:
  COPY_CODE_ASSIGN;
end;

function TNativeCompiler.Get_LADD_Code(const Op: TInstruction): TBytes;
label i_stack_stack, f_stack_stack, body;
begin
  goto body;
  i_stack_stack: FRegisters[FSP^ + Op.Args[0].Arg].i += FRegisters[FSP^ + Op.Args[1].Arg].i;
  f_stack_stack: FRegisters[FSP^ + Op.Args[0].Arg].f += FRegisters[FSP^ + Op.Args[1].Arg].f;
  // handle globals where stackptr is 0, not needed for limited test.
  body:
  COPY_CODE_ASSIGN;
end;

function TNativeCompiler.Get_LSUB_Code(const Op: TInstruction): TBytes;
label i_stack_stack, f_stack_stack, body;
begin
  goto body;
  i_stack_stack: FRegisters[FSP^ + Op.Args[0].Arg].i -= FRegisters[FSP^ + Op.Args[1].Arg].i;
  f_stack_stack: FRegisters[FSP^ + Op.Args[0].Arg].f -= FRegisters[FSP^ + Op.Args[1].Arg].f;
  // handle globals where stackptr is 0, not needed for limited test.
  body:
  COPY_CODE_ASSIGN;
end;


procedure TNativeCompiler.PrepRegisters();
begin
  FillByte(Self.FRegisters, Length(FRegisters)*SizeOf(Int64), 0);
end;

procedure TNativeCompiler.LoadConstants(C: TConstantList);
var i,j,n: Int32;
begin
  for i:=0 to C.High() do
    Self.FRegisters[i].r := C.Data[i].raw;

  // offset to a point after consts (and maybe globals in future)!
  n := C.High()+1;
  with Self.Bytecode do
    for i:=0 to Code.High do
       for j:=0 to High(Code.Data[i].Args) do
          if Code.Data[i].Args[j].Pos = EMemPos.mpUnalloc then
            Code.Data[i].Args[j].Arg += n;
end;

function TNativeCompiler.MakeExecutable(Code: TBytes; Size: Int32): TInstruction;
var ptr: PBYTE; i: Int32;
begin
  Code[Size] := $c3; // ret signal, may need to handle prologue

  ptr := VirtualAlloc(nil, Size+1, $00002000 or $00001000, $40);
  for i:=0 to Size do ptr^ := Code[i];

  Result.Code := EByteCode.bcINVOKEX;
  Result.nArgs:= 1;
  Result.Args[0].Arg:=PtrUInt(ptr);
  Result.Args[0].Pos:=EMemPos.mpRaw;
  Result.Args[0].Typ:=EExpressBaseType.xtPointer;
end;

function TNativeCompiler.Compile(BC: TByteCode): TByteCode;
type
  TJumpLocation = record From, Goal, NewGoal, NewFrom: Int32; end;
var
  i,j: Int32;
  jumps: array of TJumpLocation;
  jmp: TJumpLocation;


  compiled, code: TBytes;
  compiledTop: Int32;

  instruction: TInstruction;

  procedure AddJump(const From, Goal: PtrUInt);
  begin
    SetLength(jumps, Length(jumps)+1);
    jumps[High(jumps)].From := From;
    jumps[High(jumps)].Goal := Goal;
    jumps[High(jumps)].NewGoal := $FFFFFF;
    jumps[High(jumps)].NewFrom := $FFFFFF;
  end;
var
  raw: TBytes;
  isPlatform: Boolean;
begin
  Self.Bytecode := BC;
  Self.Bytecode.Code.Free();

  //1. init stack!
  Self.PrepRegisters();

  //2. move all constants into the stack:
  Self.LoadConstants(BC.Constants);


  for i:=0 to bc.Code.High do
  begin
    if bc.Code.data[i].Code = bcRELJMP then AddJump(i, i+bc.Code.data[i].Args[0].Arg);
    if bc.Code.data[i].Code = bcJZ     then AddJump(i, bc.Code.data[i].Args[1].Arg);
    if bc.Code.data[i].Code = bcJNZ    then AddJump(i, bc.Code.data[i].Args[1].Arg);
  end;

  SetLength(compiled, 1024);
  compiledTop := -1;

  Self.Bytecode.Init();
  for i:=0 to bc.Code.High do
  begin
    isPlatform := False;

    // patch location
    for j:=0 to High(jumps) do
    begin
      isPlatform := jumps[j].Goal = i;
      if isPlatform then break;
    end;

    // some jumps are actually landing zones, and we can't land inside compiled code!
    // so we break up the compiled code!
    if isPlatform then
    begin
      if compiledTop <> -1 then
      begin
        instruction := Self.MakeExecutable(Compiled, compiledTop+1);
        Self.Bytecode.Code.Add(instruction);
        compiledTop := -1;
      end;
    end;

    // guarded opcodes essentially, these will flow interpreted for now
    if (bc.Code.Data[i].Code in [bcJZ, bcJNZ, bcRELJMP, RETURN]) then
    begin
      if compiledTop <> -1 then
      begin
        instruction := Self.MakeExecutable(Compiled, compiledTop+1);
        Self.Bytecode.Code.Add(instruction);
        compiledTop := -1;
      end;

      instruction := bc.Code.data[i];
      Self.Bytecode.Code.Add(instruction);

      // patch location
      for j:=0 to High(jumps) do
        if jumps[j].From = i then
          jumps[j].NewFrom := Bytecode.Code.High();

    end
    else
    begin

      case bc.Code.Data[i].Code of
        bcASGN: code := Get_ASGN_Code(bc.Code.data[i]);
        bcLADD: code := Get_LADD_Code(bc.Code.data[i]);
        bcLSUB: code := Get_LSUB_Code(bc.Code.data[i]);

        bcLTE:  code := Get_LTE_Code(bc.Code.data[i]);
        bcEQ:   code := Get_EQ_Code (bc.Code.data[i]);
        bcMUL:  code := Get_MUL_Code(bc.Code.data[i]);
      end;

      if Length(code) > Length(compiled)-(compiledTop+10) then
        SetLength(compiled, Length(compiled) + Length(code));
      Move(code[0], compiled[compiledTop+1], Length(code));
      compiledTop += Length(code);
      //add code to the final compiled .. compiled.Extend(code)
    end;

    for j:=0 to High(jumps) do
      if jumps[j].Goal = i then
        jumps[j].NewGoal := Bytecode.Code.High()+1;
  end;


  // patch jumps
  for i:=0 to Self.Bytecode.Code.High do
    if (Self.Bytecode.Code.Data[i].Code in [bcJZ, bcJNZ, bcRELJMP]) then
    begin
      for j:=0 to High(jumps) do
      begin
        if jumps[j].NewFrom = i then
        begin

          if Self.Bytecode.Code.data[i].Code = bcRELJMP then Self.Bytecode.Code.data[i].Args[0].Arg := jumps[j].NewGoal - i;
          if Self.Bytecode.Code.data[i].Code = bcJZ     then Self.Bytecode.Code.data[i].args[1].Arg := jumps[j].NewGoal;
          if Self.Bytecode.Code.data[i].Code = bcJNZ    then Self.Bytecode.Code.data[i].args[1].Arg := jumps[j].NewGoal;
        end;
      end;
    end;
end;



end.