Simple RISC-y VM in suboptimal Haskell

Main.hs

module Main where

import Test.Hspec
import VM

($=) = shouldBe

main :: IO ()
main = hspec $ do
	describe "runVM" $ do
		it "pushes" $ do
			run [Push 1] $= [1]
			run [Push 1, Push 2] $= [2, 1]

		it "pops" $ do
			run [Push 1, Pop] $= []

		it "duplicates" $ do
			run [Push 1, Dup] $= [1, 1]

		it "rotates" $ do
			run [Push 1, Push 2, Push 3, Rot] $= [2, 3, 1]

		it "jumps relatively" $ do
			run [Push 1,
			     JmpR 1,
				 Push 2,
				 Push 3] $= [3, 1]

		it "subtracts and branches" $ do
			run [Push 5, SubLEZ 3 1, JmpR 1, Push 100, Push 200] $= [200, 2]
			run [Push 5, SubLEZ 5 1, JmpR 1, Push 100, Push 200] $= [200, 100, 0]
			run [Push 5, SubLEZ 8 1, JmpR 1, Push 100, Push 200] $= [200, 100, -3]

		it "calls" $ do
			run [Call 2, Push 100, Syscall (-1), Push 200, Ret, Push 300] $= [100, 200]

VM.hs

{-# LANGUAGE LambdaCase #-}

module VM where

import Control.Monad.State
import Control.Applicative ((<$>), (<*>))

data Instr = Push Int
           | Pop
           | Dup
           | Swap
           | Rot
           | Neg
           | SubLEZ Int Int
           | Add
           | Mul
           | Div
           | JmpR Int
           | Store Int
           | Load Int
           | Syscall Int
           | Call Int
           | Ret
           deriving (Show, Read, Eq)

data VM = VM { stack :: [Int], instrs :: [Instr], pc :: Int }

type VMState = State VM

vm :: [Instr] -> VM
vm instrs = VM { stack=[], instrs=instrs, pc=0 }

modifyStk :: ([Int] -> [Int]) -> VMState ()
modifyStk f = modify (\vm@VM {stack=stack} -> vm {stack=f stack})

modifyPC :: (Int -> Int) -> VMState ()
modifyPC f = modify (\vm@VM {pc=pc} -> vm {pc=f pc})

fetch :: VMState Instr
fetch = (!!) <$> gets instrs <*> gets pc

runInstr :: Instr -> VMState ()
runInstr (Push x) = modifyStk (x:)
runInstr Pop = modifyStk tail
runInstr Dup = modifyStk (\(x:xs) -> x:x:xs)
runInstr Swap = modifyStk (\(x:y:xs) -> y:x:xs)
runInstr Rot = modifyStk (\(a:b:c:xs) -> b:a:c:xs)
runInstr Neg = modifyStk (\(x:xs) -> negate x : xs)
runInstr Add = modifyStk (\(x:y:xs) -> x+y:xs)
runInstr Mul = modifyStk (\(x:y:xs) -> x*y:xs)
runInstr Div = modifyStk (\(x:y:xs) -> x`div`y:xs)
runInstr (JmpR x) = do
	ip <- gets pc
	--vm@VM {pc=ip} <- get
	--put $ vm {pc = ip + x - 1}
	modifyPC (const $ ip + x)
runInstr (Call x) = do
	ip <- gets pc
	modifyStk (ip+1:)
	modifyPC (const $ ip + x)
runInstr Ret = do
	r:addr:xs <- gets stack
	modifyStk (const (r:xs))
	modifyPC (const $ addr - 1)
runInstr (SubLEZ a addr) = do
	ip <- gets pc
	x:xs <- gets stack
	modifyStk (const $ x-a : xs)
	if (x-a) <= 0 then
		modifyPC (const $ ip + addr)
	else return ()
runInstr (Syscall c) = case c of
	(-1) -> error "should not be here"
	0 -> error "todo: stdout"
	1 -> error "todo: stdin"
	_ -> error $ "unknown syscall " ++ show c

stepVM :: VMState ()
stepVM = fetch >>= runInstr >> modifyPC (+1)

boundsCheck :: VMState [Int] -> VMState [Int]
boundsCheck p = do
	ins <- gets instrs
	pc <- gets pc
	if pc >= length ins then gets stack
	else p

execVM :: VMState [Int]
execVM = boundsCheck $ fetch >>= \case
	Syscall (-1) -> gets stack -- exit
	_ -> stepVM >> execVM

runVM :: VM -> [Int]
runVM = evalState execVM

run :: [Instr] -> [Int]
run = runVM . vm