{
	Summary:
		Grendel Virtual (Stack) Machine
	
	## $Id: gvm.pas,v 1.11 2004/04/21 21:08:59 druid Exp $
}

unit gvm;


interface


uses 
{$IFDEF WIN32}
	Windows,
{$ENDIF}
	SysUtils, 
	Variants,
	dtypes;


const
  stackSize = 512;


type
  GVMError = procedure(owner : TObject; const errorMsg : string);
	GSystemTrap = procedure(owner : TObject; const msg : string);
	GExternalTrap = function(obj : variant; const member : string) : variant;
	GSignalTrap = procedure(owner : TObject; const signal : string);
	GWaitTrap = function(owner : TObject; const signal : string) : boolean;

  GSignature = record
    resultType : integer;
    paramTypes : array of integer;
  end;

  GExternalMethod = class
    name : string;
    classAddr, methodAddr : pointer;
    signature : GSignature;
  end;

  GSymbol = class
    id : string;
    addr : integer;
  end;

  GCodeBlock = class
		code : array of char;
		codeSize, dataSize : integer;
		symbols : GHashTable;
  end;

	GContext = class
	private
		stack : array[0..stackSize] of variant;
		data : array of variant;
		pc, sp, bp : integer;

		clockTick : integer;

		owner : TObject;
    	block : GCodeBlock;

	protected
		procedure callMethod(classAddr, methodAddr : pointer; signature : GSignature);

		function findSymbol(const id : string) : integer;
	    procedure setEntryPoint(addr : integer);

		procedure push(v : variant);
		function pop() : variant;

	public
    	procedure load(cb : GCodeBlock);

		procedure run();
		
		function existsSymbol(const id : string) : boolean;
		function runSymbol(const id : string; params : array of variant) : boolean;
		function getResult() : variant;
		
		constructor Create(owner : TObject);
		destructor Destroy(); override;
	end;


var
	cmdline : string;
	input : file;
	vmError : GVMError;
	systemTrap : GSystemTrap;
	externalTrap : GExternalTrap;
	signalTrap : GSignalTrap;
	waitTrap : GWaitTrap;
	externalMethods : GHashTable;
	codeCache : GHashTable;


function loadCode(const fname : string) : GCodeBlock;

procedure setVMError(method : GVMError);
procedure setSystemTrap(method : GSystemTrap);
procedure setExternalTrap(method : GExternalTrap);
procedure setSignalTrap(method : GSignalTrap);
procedure setWaitTrap(method : GWaitTrap);

procedure registerExternalMethod(const name : string; classAddr, methodAddr : pointer; const signature : GSignature); overload;
procedure registerExternalMethod(const name : string; classAddr : TObject; resultType : integer; paramTypes : array of integer); overload;


implementation


uses 
	fsys,
	console,
	gasmdef;


procedure dummyError(owner : TObject; const msg : string);
begin
	writeConsole('Fatal VM error: ' + msg, 0);
end;

procedure dummySystemTrap(owner : TObject; const msg : string);
begin
	writeConsole('Trap: ' + msg, 0);
end;

function dummyExternalTrap(obj : variant; const member : string) : variant;
begin
  Result := Null;
end;

procedure dummySignalTrap(owner : TObject; const signal : string);
begin
end;

function dummyWaitTrap(owner : TObject; const signal : string) : boolean;
begin
  Result := True;
end;

function loadCode(const fname : string) : GCodeBlock;
var
  cb : GCodeBlock;
  input : file;
  sym : GSymbol;
  t : byte;
begin
  Result := nil;
  cb := GCodeBlock(codeCache.get(fname));

  if (cb = nil) then
    begin
    cb := GCodeBlock.Create;
    cb.symbols := GHashTable.Create(128);
    
    codeCache.put(fname, cb);

    assign(input, translateFileName(fname));
    {$I-}
    reset(input, 1);
    {$I+}

    if (IOResult <> 0) then
      begin
      vmError(nil, 'could not open ' + fname);
      exit;
      end;

    blockread(input, cb.codeSize, 4);
    blockread(input, cb.dataSize, 4);

    setLength(cb.code, cb.codeSize);

    blockread(input, cb.code[0], cb.codeSize);

    while (not eof(input)) do
      begin
      sym := GSymbol.Create;

      blockread(input, t, 1);
      setLength(sym.id, t);
      blockread(input, sym.id[1], t);
      blockread(input, sym.addr, 4);

      cb.symbols.put(sym.id, sym);
      end;

    closefile(input);
    end;

  Result := cb;
end;

// GContext
constructor GContext.Create(owner : TObject);
begin
	inherited Create();
	
	Self.owner := owner;
end;

destructor GContext.Destroy();
begin
	SetLength(data, 0);
	
	inherited Destroy();
end;

function GContext.findSymbol(const id : string) : integer;
var
  sym : GSymbol;
begin
  Result := -1;

  if (block = nil) then
    exit;

  sym := GSymbol(block.symbols.get(id));

  if (sym <> nil) then
    Result := sym.addr;
end;

procedure GContext.setEntryPoint(addr : integer);
begin
  if (addr >= 0) then
    push(pc);

  pc := addr;
end;

procedure GContext.push(v : variant);
begin
  if (sp > stackSize) then
    vmError(owner, 'data stack overflow');

  inc(sp);
  stack[sp] := v;
end;

function GContext.pop() : variant;
begin
  if (sp < 0) then
    vmError(owner, 'data stack underflow');

  Result := stack[sp];
  dec(sp);
end;

procedure GContext.load(cb : GCodeBlock);
var
	i : integer;
begin
  sp := -1;
  pc := -1;

  block := cb;
  clockTick := 0;

  if (cb <> nil) then
    begin
    setLength(data, cb.dataSize);

    for i := 0 to cb.dataSize-1 do
      data[i] := 0;
    end
  else
    setLength(data, 0);
end;

procedure GContext.callMethod(classAddr, methodAddr : pointer; signature : GSignature);
var
	i : integer;
  v, vd : variant;
  resstr : string;
begin
  if (methodAddr = nil) then
    exit;
    
  for i := length(signature.ParamTypes) - 1 downto 0 do
    begin
    v := stack[sp - i];

    VarCast(vd, v, signature.ParamTypes[i]);

    case varType(vd) of
      varBoolean: asm
                  xor eax, eax
                  mov ax, vd.TVarData.VBoolean
                  push eax
                  end;
      varInteger: asm
                  mov eax, vd.TVarData.VInteger
                  push eax
                  end;
       varSingle: asm
                  mov eax, vd.TVarData.VSingle
                  push eax
                  end;
       varString: asm
                  mov eax, vd.TVarData.VString
                  push eax
                  end;
    end;
    end;
    
  dec(sp, length(signature.paramTypes));

  asm
    mov eax, classAddr
    test eax, eax
    jz @strresult

    @methodcall:
    push eax

    @strresult:
    mov eax, signature.ResultType
    cmp eax, varString
    jne @call
    lea eax, resstr
    push eax

    @call:
    call methodAddr

    mov edx, signature.ResultType

    cmp edx, varSingle
    je @varSingle

    cmp edx, varInteger
    je @varInteger

    cmp edx, varBoolean
    je @varBoolean

    jmp @end

@varSingle:
    fstp dword ptr vd.TVarData.VSingle
    mov vd.TVarData.VType, varSingle
    jmp @end

@varInteger:
    mov vd.TVarData.VType, varInteger
    mov vd.TVarData.VInteger, eax
    jmp @end

@varBoolean:
    mov vd.TVarData.VType, varBoolean   
    xor ah,ah   
    mov vd.TVarData.VBoolean, ax
    jmp @end

@end:
  end;
  
  if (signature.ResultType = varString) then
    push(resstr)
  else
  if (signature.ResultType <> varEmpty) then
    push(vd);
end;


procedure GContext.run();
var
	i : integer;
  f : single;
  p : pchar;
	v1, v2 : variant;
  meth : GExternalMethod;
begin
  if (block = nil) or (pc < 0) or (pc >= block.codeSize) then
    exit;

  try
    while (pc >= 0) and (pc < block.codeSize) do
    case ord(block.code[pc]) of
      _TOF    : begin
                VarCast(v1, pop(), varSingle);
                push(v1);
                inc(pc);
                end;
      _TOI    : begin
                VarCast(v1, pop(), varInteger);
                push(v1);
                inc(pc);
                end;
      _TOS    : begin
                VarCast(v1, pop(), varString);
                push(v1);
                inc(pc);
                end;
      _PUSHI 	: begin
                move(block.code[pc + 1], i, 4);
                inc(pc, 5);
                push(i);
                end;
      _PUSHF  : begin
                move(block.code[pc + 1], f, 4);
                inc(pc, 5);
                push(f);
                end;
      _PUSHS  : begin
                p := @block.code[pc + 1];
                inc(pc, strlen(p) + 2);

                push(string(p));
                end;
       _PUSHR : begin
                move(block.code[pc + 1], i, 4);
                inc(pc, 5);
                push(data[i]);
                end;
        _POPR : begin
                move(block.code[pc + 1], i, 4);
                inc(pc, 5);
                data[i] := pop();
                end;
    _PUSHDISP : begin
                move(block.code[pc + 1], i, 4);
                inc(pc, 5);
                push(stack[bp + i]);
                end;
     _POPDISP : begin
                move(block.code[pc + 1], i, 4);
                inc(pc, 5);
                stack[bp + i] := pop();
                end;
      _ADD		: begin
                v2 := pop();
                v1 := pop();
                push(v1 + v2);
                inc(pc);
                end;
      _SUB		: begin
                v2 := pop();
                v1 := pop();
                push(v1 - v2);
                inc(pc);
                end;
      _MUL		: begin
                v2 := pop();
                v1 := pop();
                push(v1 * v2);
                inc(pc);
                end;
      _DIV		: begin
                v2 := pop();
                v1 := pop();
                push(v1 / v2);
                inc(pc);
                end;
      _NOT    : begin
                push(not pop());
                inc(pc);
                end;
      _AND    : begin
                push(pop() and pop());
                inc(pc);
                end;
      _OR     : begin
                push(pop() or pop());
                inc(pc);
                end;
      _LT     : begin
                v2 := pop();
                v1 := pop();
                push(v1 < v2);
                inc(pc);
                end;
      _GT     : begin
                v2 := pop();
                v1 := pop();
                push(v1 > v2);
                inc(pc);
                end;
      _LTE    : begin
                v2 := pop();
                v1 := pop();
                push(v1 <= v2);
                inc(pc);
                end;
      _GTE    : begin
                v2 := pop();
                v1 := pop();
                push(v1 >= v2);
                inc(pc);
                end;
      _EQ     : begin
                v2 := pop();
                v1 := pop();
                push(v1 = v2);
                inc(pc);
                end;
      _GET		: begin
                v2 := pop();
                v1 := pop();
                push(externalTrap(v1, v2));
                inc(pc);
                end;
      _TRAP		: begin
                systemTrap(owner, pop());
                inc(pc);
                end;
      _SLEEP  : begin
                v1 := pop();

                if (v1 <= 0) then
                  inc(pc)
                else
                  begin
                  push(v1 - 1);
                  break;
                  end;
                end;
      _WAIT   : begin
                v1 := pop();

                if (not waitTrap(owner, v1)) then
                  begin
                  push(v1);
                  break;
                  end
                else
                  inc(pc);
                end;
      _SIGNAL : begin
                v1 := pop();
                inc(pc);
                signalTrap(owner, v1);
                end;
      _RET		: begin
                i := pop();
                pc := i;
                end;
      _CALL 	: begin
                move(block.code[pc + 1], i, 4);

                if (i < 0) or (i > block.codeSize) then
                  vmError(owner, 'procedure call outside of boundary');

                push(pc + 5);					// save return address
                pc := i;
                end;
      _CALLE  : begin
                p := @block.code[pc + 1];
                inc(pc, strlen(p) + 2);

                meth := GExternalMethod(externalMethods.get(string(p)));

                if (meth <> nil) then
                  callMethod(meth.classAddr, meth.methodAddr, meth.signature)
                else
                  vmError(owner, 'unregistered external method "' + p + '"');
                end;
      _JMP    : begin
                move(block.code[pc + 1], i, 4);

                if (i < 0) or (i > block.codeSize) then
                  vmError(owner, 'jump outside of boundary');

                pc := i;
                end;
      _JZ     : begin
                move(block.code[pc + 1], i, 4);
                v1 := pop();

                if (i < 0) or (i > block.codeSize) then
                  vmError(owner, 'jump outside of boundary');

                if (integer(v1) = 0) then
                  pc := i
                else
                  inc(pc, 5);
                end;
      _JNZ    : begin
                move(block.code[pc + 1], i, 4);
                v1 := pop();

                if (i < 0) or (i > block.codeSize) then
                  vmError(owner, 'jump outside of boundary');

                if (integer(v1) <> 0) then
                  pc := i
                else
                  inc(pc, 5);
                end;
      _PUSHBP : begin 
                push(bp);
                inc(pc);
                end;
       _POPBP : begin 
                bp := pop();
                inc(pc);
                end;
       _MBPSP : begin
                sp := bp;
                inc(pc);
                end;
       _MSPBP : begin
                bp := sp;
                inc(pc);
                end;
       _ADDSP : begin
                move(block.code[pc + 1], i, 4);
                inc(sp, i);
                inc(pc, 5);
                end;
       _SUBSP : begin
                move(block.code[pc + 1], i, 4);
                dec(sp, i);
                inc(pc, 5);
                end;
        _MTSD : begin
                move(block.code[pc + 1], i, 4);
                stack[sp - i] := stack[sp];
                inc(pc, 5);
                end;
      	_HALT : pc := block.codeSize;
    else
      inc(pc);
    end;
  except
    on E : Exception do
      begin
      vmError(owner, 'stack error: ' + E.Message);

      // reset state, stop program
      sp := -1;
      bp := 0;
      pc := -1;
      end;
  end;
end;

function GContext.existsSymbol(const id : string) : boolean;
begin
	Result := (findSymbol(id) <> -1);
end;

function GContext.runSymbol(const id : string; params : array of variant) : boolean;
var
	addr : integer;
	i : integer;
begin
	Result := false;
	
	addr := findSymbol(id);
	
	if (addr <> - 1) then
		begin
		// parameters in params are left to right, we need to push them in reverse
		for i := length(params) - 1 downto 0 do
			push(params[i]);
			
		setEntryPoint(addr);
		run();
		
		Result := true;
		end;
end;

function GContext.getResult() : variant;
begin
	Result := pop();
end;

procedure setVMError(method : GVMError);
begin
  if (Assigned(method)) then
    vmError := method;
end;

procedure setSystemTrap(method : GSystemTrap);
begin
  if (Assigned(method)) then
    systemTrap := method;
end;

procedure setExternalTrap(method : GExternalTrap);
begin
  if (Assigned(method)) then
    externalTrap := method;
end;

procedure setSignalTrap(method : GSignalTrap);
begin
  if (Assigned(method)) then
    signalTrap := method;
end;

procedure setWaitTrap(method : GWaitTrap);
begin
  if (Assigned(method)) then
    waitTrap := method;
end;

procedure registerExternalMethod(const name : string; classAddr, methodAddr : pointer; const signature : GSignature);
var
	meth : GExternalMethod;
begin
  meth := GExternalMethod.Create;

  meth.name := name;
  meth.classAddr := classAddr;
  meth.methodAddr := methodAddr;
  meth.signature := signature;

  externalMethods.put(name, meth);
end;

procedure registerExternalMethod(const name : string; classAddr : TObject; resultType : integer; paramTypes : array of integer);
var
	sig : GSignature;
	x : integer;
begin
	sig.resultType := resultType;
	
	SetLength(sig.paramTypes, Length(paramTypes));
	
	for x := 0 to High(paramTypes) do
		sig.paramTypes[x] := paramTypes[x];
	
	registerExternalMethod(name, classAddr, classAddr.MethodAddress(name), sig);
end;

initialization
	DecimalSeparator := '.';

	setVMError(dummyError);
	setSystemTrap(dummySystemTrap);
	setExternalTrap(dummyExternalTrap);
	setSignalTrap(dummySignalTrap);
	setWaitTrap(dummyWaitTrap);

	codeCache := GHashTable.Create(128);
	externalMethods := GHashTable.Create(256);

finalization
	codeCache.Clear();
	codeCache.Free();
	
	externalMethods.Clear();
	externalMethods.Free();
	
end.