SilverSight/fortran/AVMIsa/avm.f90

! AVM ISA v1 — Fortran Port (Strict Functional Execution)
module avm
  implicit none

  integer, parameter :: Q16_SCALE = 65536
  integer, parameter :: MAX_STACK = 1024
  integer, parameter :: MAX_LOCALS = 16
  integer, parameter :: MAX_PROG = 256
  integer, parameter :: AVM_CLAMP_MAX = 2147483647
  integer, parameter :: AVM_CLAMP_MIN = -2147483647

  ! Value type codes
  integer, parameter :: VAL_Q16 = 0, VAL_BOOL = 1

  type :: AvmVal
    integer :: ty = VAL_Q16
    integer :: val = 0
  end type

  ! Primitive codes
  integer, parameter :: PRIM_ADD = 0, PRIM_SUB = 1, PRIM_MUL = 2, PRIM_DIV = 3
  integer, parameter :: PRIM_LT = 4, PRIM_EQ = 5, PRIM_AND = 6, PRIM_OR = 7, PRIM_NOT = 8

  ! Instruction opcodes
  integer, parameter :: I_PUSH_Q16 = 0, I_PUSH_BOOL = 1, I_POP = 2, I_DUP = 3
  integer, parameter :: I_SWAP = 4, I_LOAD = 5, I_STORE = 6, I_JUMP = 7
  integer, parameter :: I_JUMP_IF = 8, I_PRIM = 9, I_HALT = 10

  type :: Instr
    integer :: op = 0
    integer :: arg = 0
    logical :: arg2 = .false.
  end type

  type :: State
    integer :: pc = 0
    type(AvmVal) :: stack(MAX_STACK)
    integer :: sp = 0
    type(AvmVal) :: locals(MAX_LOCALS)
    logical :: halted = .false.
  end type

contains

  function q16_mul(a, b) result(r)
    integer, intent(in) :: a, b
    integer :: r
    r = int((int(a, 8) * int(b, 8)) / Q16_SCALE)
  end function

  function q16_div(a, b) result(r)
    integer, intent(in) :: a, b
    integer :: r
    if (b == 0) then
      r = 2147483647; return
    end if
    r = int((int(a, 8) * Q16_SCALE) / int(b, 8))
  end function

  function avm_clamp64(x) result(r)
    integer(kind=8), intent(in) :: x
    integer :: r
    if (x > AVM_CLAMP_MAX) then; r = AVM_CLAMP_MAX
    else if (x < AVM_CLAMP_MIN) then; r = AVM_CLAMP_MIN
    else; r = int(x); end if
  end function

  function avm_clamp32(x) result(r)
    integer, intent(in) :: x
    integer :: r
    if (x > AVM_CLAMP_MAX) then; r = AVM_CLAMP_MAX
    else if (x < AVM_CLAMP_MIN) then; r = AVM_CLAMP_MIN
    else; r = x; end if
  end function

  function floor_div(a, b) result(r)
    integer(kind=8), intent(in) :: a, b
    integer :: r
    integer(kind=8) :: q, rr
    if (b == 0) then; r = 0; return; end if
    q = a / b; rr = mod(a, b)
    if (rr /= 0 .and. ieor(a, b) < 0) q = q - 1
    r = int(q)
  end function

  subroutine step_sub(s_in, prog, prog_len, s_out, err)
    type(State), intent(in) :: s_in
    type(Instr), intent(in) :: prog(*)
    integer, intent(in) :: prog_len
    type(State), intent(out) :: s_out
    integer, intent(out) :: err
    type(AvmVal) :: a, b, result
    integer :: arity

    s_out = s_in; err = 0
    if (s_out%halted) return
    if (s_out%pc < 0 .or. s_out%pc >= prog_len) then
      s_out%halted = .true.; return
    end if

    select case (prog(s_out%pc + 1)%op)
    case (I_PUSH_Q16)
      if (s_out%sp >= MAX_STACK) then; err = -2; return; end if
      s_out%sp = s_out%sp + 1
      s_out%stack(s_out%sp)%ty = VAL_Q16
      s_out%stack(s_out%sp)%val = avm_clamp32(prog(s_out%pc + 1)%arg)
    case (I_PUSH_BOOL)
      if (s_out%sp >= MAX_STACK) then; err = -2; return; end if
      s_out%sp = s_out%sp + 1
      s_out%stack(s_out%sp)%ty = VAL_BOOL
      s_out%stack(s_out%sp)%val = merge(1, 0, prog(s_out%pc + 1)%arg2)
    case (I_POP)
      if (s_out%sp <= 0) then; err = -3; return; end if
      s_out%sp = s_out%sp - 1
    case (I_DUP)
      if (s_out%sp <= 0) then; err = -3; return; end if
      if (s_out%sp >= MAX_STACK) then; err = -2; return; end if
      s_out%stack(s_out%sp + 1) = s_out%stack(s_out%sp)
      s_out%sp = s_out%sp + 1
    case (I_SWAP)
      if (s_out%sp < 2) then; err = -4; return; end if
      a = s_out%stack(s_out%sp); s_out%stack(s_out%sp) = s_out%stack(s_out%sp - 1)
      s_out%stack(s_out%sp - 1) = a
    case (I_LOAD)
      if (s_out%sp >= MAX_STACK) then; err = -2; return; end if
      s_out%sp = s_out%sp + 1
      s_out%stack(s_out%sp) = s_out%locals(prog(s_out%pc + 1)%arg + 1)
    case (I_STORE)
      if (s_out%sp <= 0) then; err = -3; return; end if
      s_out%locals(prog(s_out%pc + 1)%arg + 1) = s_out%stack(s_out%sp)
      s_out%sp = s_out%sp - 1
    case (I_JUMP)
      s_out%pc = prog(s_out%pc + 1)%arg; return
    case (I_JUMP_IF)
      if (s_out%sp <= 0) then; err = -3; return; end if
      a = s_out%stack(s_out%sp); s_out%sp = s_out%sp - 1
      if (a%val /= 0) s_out%pc = prog(s_out%pc + 1)%arg - 1
    case (I_PRIM)
      arity = merge(1, 2, prog(s_out%pc + 1)%arg == PRIM_NOT)
      if (s_out%sp < arity) then; err = -4; return; end if
      b%ty = VAL_Q16; b%val = 0
      if (arity >= 2) then; b = s_out%stack(s_out%sp); s_out%sp = s_out%sp - 1; end if
      a = s_out%stack(s_out%sp); s_out%sp = s_out%sp - 1
      select case (prog(s_out%pc + 1)%arg)
      case (PRIM_ADD); result%ty = VAL_Q16; result%val = avm_clamp64(int(a%val, 8) + int(b%val, 8))
      case (PRIM_SUB); result%ty = VAL_Q16; result%val = avm_clamp64(int(a%val, 8) - int(b%val, 8))
      case (PRIM_MUL); result%ty = VAL_Q16; result%val = avm_clamp64(int(floor_div(int(a%val, 8) * int(b%val, 8), int(Q16_SCALE, 8)), 8))
      case (PRIM_DIV)
        if (b%val == 0) then; err = -8; return; end if
        result%ty = VAL_Q16; result%val = avm_clamp64(int(floor_div(int(a%val, 8) * Q16_SCALE, int(b%val, 8)), 8))
      case (PRIM_LT); result%ty = VAL_BOOL; result%val = merge(1, 0, a%val < b%val)
      case (PRIM_EQ); result%ty = VAL_BOOL; result%val = merge(1, 0, a%val == b%val)
      case (PRIM_AND); result%ty = VAL_BOOL; result%val = merge(1, 0, a%val /= 0 .and. b%val /= 0)
      case (PRIM_OR); result%ty = VAL_BOOL; result%val = merge(1, 0, a%val /= 0 .or. b%val /= 0)
      case (PRIM_NOT); result%ty = VAL_BOOL; result%val = merge(1, 0, a%val == 0)
      end select
      s_out%sp = s_out%sp + 1; s_out%stack(s_out%sp) = result
    case (I_HALT)
      s_out%halted = .true.
    end select
    s_out%pc = s_out%pc + 1
  end subroutine

end module