source: branches/virt simple/UMachine.pas

unit UMachine;

{$mode delphi}{$H+}

interface

uses
  Classes, SysUtils, fgl, UBigInt;

type
  TOpcode = (opNoOperation, opHalt, opLoad, opIncrement, opDecrement, opPush,
    opPop, opCall, opReturn, opJumpAbsolute, opJumpRelative, opAdd, opSubtract,
    opMultiply, opDivide, opModulo, opExchange, opInput, opOutput, opSkip,
    opSystemCall);
  TSpecialRegister = (srIP, srSP);

const
  OpcodeString: array[TOpcode] of string = ('NOP', 'HALT', 'LD',
    'INC', 'DEC', 'PUSH', 'POP', 'CALL', 'RET', 'JP', 'JR', 'ADD', 'SUB', 'MUL',
    'DIV', 'MOD', 'EX', 'IN', 'OUT', 'SKIP', 'SYS');
  SpecialRegisterString: array[TSpecialRegister] of string = ('IP', 'SP');

type
  TParamType = (ptNone, ptConst, ptRegister, ptSpecialRegister);
  TCondition = (cdZero, cdNotZero, cdNegative, cdPositive);
  TMemoryType = (mtNone, mtData);

  TValue = Integer;
  //TValue = TBigInt;
  TAddress = Integer;

  { TParam }

  TParam = class
    ParamType: TParamType;
    MemoryType: TMemoryType;
    Value: TValue;
    function GetString: string;
    procedure SetParam(ParamType: TParamType; MemoryType: TMemoryType; Value: TValue);
  end;

  { TInstruction }

  TInstruction = class
    Opcode: TOpcode;
    Params: array[0..1] of TParam;
    constructor Create;
    destructor Destroy; override;
    function GetString: string;
  end;

  TInstructions = class(TFPGObjectList<TInstruction>)
    procedure AddInst(Opcode: TOpcode); overload;
    procedure AddInst(Opcode: TOpcode;
      ParamType1: TParamType; Indirect1: TMemoryType; Value1: TValue);  overload;
    procedure AddInst(Opcode: TOpcode;
      ParamType1: TParamType; Indirect1: TMemoryType; Value1: TValue;
      ParamType2: TParamType; Indirect2: TMemoryType; Value2: TValue);  overload;
  end;

  TPortOutEvent = procedure (Sender: TObject; Port: Integer; Value: TValue) of object;
  TPortInEvent = function (Sender: TObject; Port: Integer): TValue of object;

  TInstructionHandler = procedure of object;
  TSystemCallEvent = procedure(Index: TValue) of object;

  TMachineThread = class;

  { TMachine }

  TMachine = class
  private
    FOnPortIn: TPortInEvent;
    FOnPortOut: TPortOutEvent;
    FOnSystemCall: TSystemCallEvent;
    FRunning: Boolean;
    InstructionHandlers: array[TOpcode] of TInstructionHandler;
    Thread: TMachineThread;
    function GetValue(Param: TParam): TValue;
    procedure InstructionAdd;
    procedure InstructionCall;
    procedure InstructionDecrement;
    procedure InstructionDivide;
    procedure InstructionExchange;
    procedure InstructionHalt;
    procedure InstructionIncrement;
    procedure InstructionInput;
    procedure InstructionJumpAbsolute;
    procedure InstructionJumpRelative;
    procedure InstructionLoad;
    procedure InstructionModulo;
    procedure InstructionMultiply;
    procedure InstructionNoOperation;
    procedure InstructionOutput;
    procedure InstructionPop;
    procedure InstructionPush;
    procedure InstructionReturn;
    procedure InstructionSkip;
    procedure InstructionSubtract;
    procedure InstructionSystemCall;
    procedure SetValue(Param: TParam; Value: TValue);
  public
    Instructions: TInstructions;
    Registers: TFPGList<TValue>;
    Memory: TFPGList<TValue>;
    IP: TAddress;
    SP: TAddress;
    Terminated: Boolean;
    procedure Init(MemorySize, RegisterCount: Integer);
    procedure Run;
    procedure Start;
    procedure Stop;
    constructor Create;
    destructor Destroy; override;
    property Running: Boolean read FRunning;
    property OnPortOut: TPortOutEvent read FOnPortOut write FOnPortOut;
    property OnPortIn: TPortInEvent read FOnPortIn write FOnPortIn;
    property OnSystemCall: TSystemCallEvent read FOnSystemCall write FOnSystemCall;
  end;

  { TMachineThread }

  TMachineThread = class(TThread)
    Machine: TMachine;
    procedure Execute; override;
  end;


implementation

{ TMachineThread }

procedure TMachineThread.Execute;
begin
  Machine.Run;
end;


{ TParam }

function TParam.GetString: string;
begin
  if ParamType = ptConst then Result := IntToHex(Value, 8)
  else if ParamType = ptRegister then Result := 'R' + IntToStr(Value)
  else if ParamType = ptSpecialRegister then begin
    if Value < Length(SpecialRegisterString) then
      Result := SpecialRegisterString[TSpecialRegister(Value)]
      else Result := 'S' + IntToStr(Value);
  end;
  if MemoryType = mtData then Result := '[' + Result + ']';
end;

procedure TParam.SetParam(ParamType: TParamType; MemoryType: TMemoryType;
  Value: TValue);
begin
  Self.ParamType := ParamType;
  Self.MemoryType := MemoryType;
  Self.Value := Value;
end;

{ TInstruction }

constructor TInstruction.Create;
begin
  Params[0] := TParam.Create;
  Params[1] := TParam.Create;
end;

destructor TInstruction.Destroy;
begin
  FreeAndNil(Params[0]);
  FreeAndNil(Params[1]);
  inherited;
end;

function TInstruction.GetString: string;
begin
  Result := OpcodeString[Opcode];
  if Params[0].ParamType <> ptNone then begin
    Result := Result + ' ' + Params[0].GetString;
    if Params[1].ParamType <> ptNone then begin
      Result := Result + ', ' + Params[1].GetString;
    end;
  end;
end;

{ TInstructions }

procedure TInstructions.AddInst(Opcode: TOpcode);
var
  NewInst: TInstruction;
begin
  NewInst := TInstruction.Create;
  NewInst.Opcode := Opcode;
  NewInst.Params[0].SetParam(ptNone, mtNone, 0);
  NewInst.Params[1].SetParam(ptNone, mtNone, 0);
  Add(NewInst);
end;

procedure TInstructions.AddInst(Opcode: TOpcode; ParamType1: TParamType;
  Indirect1: TMemoryType; Value1: TValue);
var
  NewInst: TInstruction;
begin
  NewInst := TInstruction.Create;
  NewInst.Opcode := Opcode;
  NewInst.Params[0].SetParam(ParamType1, Indirect1, Value1);
  NewInst.Params[1].SetParam(ptNone, mtNone, 0);
  Add(NewInst);
end;

procedure TInstructions.AddInst(Opcode: TOpcode;
  ParamType1: TParamType; Indirect1: TMemoryType; Value1: TValue;
  ParamType2: TParamType; Indirect2: TMemoryType; Value2: TValue);
var
  NewInst: TInstruction;
begin
  NewInst := TInstruction.Create;
  NewInst.Opcode := Opcode;
  NewInst.Params[0].SetParam(ParamType1, Indirect1, Value1);
  NewInst.Params[1].SetParam(ParamType2, Indirect2, Value2);
  Add(NewInst);
end;


{ TMachine }

procedure TMachine.Init(MemorySize, RegisterCount: Integer);
begin
  Instructions.Count := 0;
  Registers.Count := RegisterCount;
  Memory.Count := MemorySize;
  IP := 0;
  SP := Memory.Count;
end;

procedure TMachine.InstructionNoOperation;
begin
  // Do nothing
end;

procedure TMachine.InstructionHalt;
begin
  Terminated := True;
end;

procedure TMachine.InstructionIncrement;
begin
  with TInstruction(Instructions[IP]) do
    SetValue(Params[0], GetValue(Params[0]) + 1);
end;

procedure TMachine.InstructionDecrement;
begin
  with TInstruction(Instructions[IP]) do
    SetValue(Params[0], GetValue(Params[0]) - 1);
end;

procedure TMachine.InstructionAdd;
begin
  with TInstruction(Instructions[IP]) do
    SetValue(Params[0], GetValue(Params[0]) + GetValue(Params[1]));
end;

procedure TMachine.InstructionSubtract;
begin
  with TInstruction(Instructions[IP]) do
    SetValue(Params[0], GetValue(Params[0]) + GetValue(Params[1]));
end;

procedure TMachine.InstructionSystemCall;
begin
  if Assigned(FOnSystemCall) then
    with TInstruction(Instructions[IP]) do
      FOnSystemCall(GetValue(Params[0]));
end;

procedure TMachine.InstructionMultiply;
begin
  with TInstruction(Instructions[IP]) do
    SetValue(Params[0], GetValue(Params[0]) * GetValue(Params[1]));
end;

procedure TMachine.InstructionDivide;
begin
  with TInstruction(Instructions[IP]) do
    SetValue(Params[0], GetValue(Params[0]) div GetValue(Params[1]));
end;

procedure TMachine.InstructionModulo;
begin
  with TInstruction(Instructions[IP]) do
    SetValue(Params[0], GetValue(Params[0]) mod GetValue(Params[1]));
end;

procedure TMachine.InstructionLoad;
begin
  with TInstruction(Instructions[IP]) do
    SetValue(Params[0], GetValue(Params[1]));
end;

procedure TMachine.InstructionPush;
begin
  with TInstruction(Instructions[IP]) do begin
    SP := SP - 1;
    Memory[SP] := GetValue(Params[0]);
  end;
end;

procedure TMachine.InstructionPop;
begin
  with TInstruction(Instructions[IP]) do begin
    SetValue(Params[0], Memory[SP]);
    SP := SP + 1;
  end;
end;

procedure TMachine.InstructionJumpAbsolute;
begin
  with TInstruction(Instructions[IP]) do
    IP := GetValue(Params[0]);
end;

procedure TMachine.InstructionJumpRelative;
begin
  with TInstruction(Instructions[IP]) do
    IP := IP + GetValue(Params[0]);
end;

procedure TMachine.InstructionInput;
begin
  with TInstruction(Instructions[IP]) do
    if Assigned(FOnPortIn) then SetValue(Params[0], FOnPortIn(Self, GetValue(Params[1])))
      else SetValue(Params[0], 0);
end;

procedure TMachine.InstructionOutput;
begin
  with TInstruction(Instructions[IP]) do
    if Assigned(FOnPortOut) then FOnPortOut(Self, GetValue(Params[0]), GetValue(Params[1]));
end;

procedure TMachine.InstructionCall;
begin
  with TInstruction(Instructions[IP]) do begin
    Dec(SP);
    Memory[SP] := IP + 1;
    IP := GetValue(Params[0]);
  end;
end;

procedure TMachine.InstructionReturn;
begin
  with TInstruction(Instructions[IP]) do begin
    IP := Memory[SP];
    Inc(SP);
  end;
end;

procedure TMachine.InstructionExchange;
var
  Temp: TValue;
begin
  with TInstruction(Instructions[IP]) do begin
    Temp := GetValue(Params[0]);
    SetValue(Params[0], GetValue(Params[1]));
    SetValue(Params[1], Temp);
  end;
end;

procedure TMachine.InstructionSkip;
var
  Condition: TCondition;
begin
  with TInstruction(Instructions[IP]) do begin
    Condition := TCondition(Integer(GetValue(Params[0])));
    case Condition of
      cdZero: if GetValue(Params[1]) <> 0 then Inc(IP);
      cdNotZero: if GetValue(Params[1]) = 0 then Inc(IP);
      cdPositive: if GetValue(Params[1]) <= 0 then Inc(IP);
      cdNegative: if GetValue(Params[1]) >= 0 then Inc(IP);
      else raise Exception.Create('Unsupported condition type');
    end;
  end;
end;

procedure TMachine.Run;
begin
  while not Terminated do begin
    if IP < Instructions.Count then begin
      with TInstruction(Instructions[IP]) do
      if Assigned(InstructionHandlers[Opcode]) then
        InstructionHandlers[Opcode]
        else raise Exception.Create('Unsupported instruction opcode ' + OpcodeString[Opcode]);
    end else raise Exception.Create('Reached end of program memory');
    Inc(IP);
  end;
end;

procedure TMachine.Start;
begin
  if not Running then begin
    Terminated := False;
    Thread := TMachineThread.Create(True);
    Thread.Machine := Self;
    Thread.Start;
    FRunning := True;
  end;
end;

procedure TMachine.Stop;
begin
  if Running then begin
    Terminated := True;
    Thread.Terminate;
    Thread.WaitFor;
    FreeAndNil(Thread);
    FRunning := False;
  end;
end;

constructor TMachine.Create;
begin
  Registers := TFPGList<TValue>.Create;
  Memory := TFPGList<TValue>.Create;
  Instructions := TInstructions.Create;

  InstructionHandlers[opNoOperation] := InstructionNoOperation;
  InstructionHandlers[opHalt] := InstructionHalt;
  InstructionHandlers[opIncrement] := InstructionIncrement;
  InstructionHandlers[opDecrement] := InstructionDecrement;
  InstructionHandlers[opAdd] := InstructionAdd;
  InstructionHandlers[opSubtract] := InstructionSubtract;
  InstructionHandlers[opMultiply] := InstructionMultiply;
  InstructionHandlers[opDivide] := InstructionDivide;
  InstructionHandlers[opModulo] := InstructionModulo;
  InstructionHandlers[opLoad] := InstructionLoad;
  InstructionHandlers[opPush] := InstructionPush;
  InstructionHandlers[opPop] := InstructionPop;
  InstructionHandlers[opJumpAbsolute] := InstructionJumpAbsolute;
  InstructionHandlers[opJumpRelative] := InstructionJumpRelative;
  InstructionHandlers[opOutput] := InstructionOutput;
  InstructionHandlers[opInput] := InstructionInput;
  InstructionHandlers[opCall] := InstructionCall;
  InstructionHandlers[opReturn] := InstructionReturn;
  InstructionHandlers[opExchange] := InstructionExchange;
  InstructionHandlers[opSkip] := InstructionSkip;
  InstructionHandlers[opSystemCall] := InstructionSystemCall;
end;

destructor TMachine.Destroy;
begin
  FreeAndNil(Instructions);
  FreeAndNil(Memory);
  FreeAndNil(Registers);
  inherited Destroy;
end;

function TMachine.GetValue(Param: TParam): TValue;
begin
  if Param.ParamType = ptRegister then Result := Registers[Param.Value]
  else if Param.ParamType = ptConst then Result := Param.Value
  else if Param.ParamType = ptSpecialRegister then begin
    if Param.Value = Integer(srIP) then Result := IP
    else if Param.Value = Integer(srSP) then Result := SP
    else raise Exception.Create('Unsupported special register ' + IntToStr(Integer(Param.Value)));
  end else if Param.ParamType = ptNone then raise Exception.Create('Read from not set parameter')
  else raise Exception.Create('Unsupported parameter type ' + IntToStr(Integer(Param.ParamType)));
  if Param.MemoryType = mtData then Result := Memory[Result];
end;

procedure TMachine.SetValue(Param: TParam; Value: TValue);
begin
  if Param.ParamType = ptRegister then begin
    if Param.MemoryType = mtData then Memory[Registers[Param.Value]] := Value
      else Registers[Param.Value] := Value;
  end else
  if Param.ParamType = ptConst then begin
    if Param.MemoryType = mtData then Memory[Param.Value] := Value
      else raise Exception.Create('Cannot assign to constant parameter');
  end else
  if Param.ParamType = ptSpecialRegister then begin
    if Param.Value = Integer(srIP) then begin
      if Param.MemoryType = mtData then Memory[IP] := Value
        else IP := Value;
    end else if Param.Value = Integer(srSP) then begin
      if Param.MemoryType = mtData then Memory[SP] := Value
        else SP := Value;
    end else raise Exception.Create('Unsupported special register ' + IntToStr(Integer(Param.Value)));
  end else
  if Param.ParamType = ptNone then begin
    raise Exception.Create('Write to not set parameter')
  end else
  raise Exception.Create('Unsupported parameter type ' + IntToStr(Integer(Param.ParamType)));
end;

end.