118 lines
2.6 KiB
Haskell
118 lines
2.6 KiB
Haskell
module VirtualMachine.VM where
|
|
|
|
import Data.Foldable (toList)
|
|
import Control.Monad.Trans (lift)
|
|
import Control.Monad.State (get, put)
|
|
import Control.Monad.Except (throwError)
|
|
import Control.Monad.Trans.State (StateT)
|
|
import Control.Monad.Trans.Except (ExceptT)
|
|
import qualified Data.Sequence as S
|
|
|
|
|
|
data VM = VM { _pc :: Int
|
|
, _fp :: Int
|
|
, _stack :: S.Seq Int
|
|
, _halt :: Bool
|
|
, _debug :: Bool
|
|
} deriving (Show, Eq)
|
|
|
|
data Op = Nop -- 0x00
|
|
| Halt -- 0x01
|
|
| Push -- 0x02
|
|
| Pop -- 0x03
|
|
| Dup -- 0x04
|
|
| Swap -- 0x05
|
|
| Add -- 0x06
|
|
| Sub -- 0x07
|
|
| Mul -- 0x08
|
|
| Div -- 0x09
|
|
| Neg -- 0x0a
|
|
| Not -- 0x0b
|
|
| Call -- 0x0c
|
|
| Ret -- 0x0d
|
|
| Jmp -- 0x0e
|
|
| Je -- 0x0f
|
|
| Jne -- 0x10
|
|
| Jg -- 0x11
|
|
| Jl -- 0x12
|
|
| Jge -- 0x13
|
|
| Jle -- 0x14
|
|
| Ld -- 0x15
|
|
| In -- 0x16
|
|
| Out -- 0x17
|
|
| Clr -- 0x18
|
|
| Roll -- 0x19
|
|
| Over -- 0x1A
|
|
deriving (Eq, Ord, Enum, Show, Read, Bounded)
|
|
|
|
type Machine = StateT VM IO
|
|
|
|
empty :: VM
|
|
empty = VM { _pc = 0
|
|
, _fp = -1
|
|
, _stack = S.empty
|
|
, _halt = False
|
|
, _debug = False
|
|
}
|
|
|
|
-------------------------------------------------------------------------------
|
|
|
|
getPc :: Machine Int
|
|
getPc = get >>= (return . _pc)
|
|
|
|
getFp :: Machine Int
|
|
getFp = get >>= (return . _fp)
|
|
|
|
isHalted :: Machine Bool
|
|
isHalted = get >>= (return . _halt)
|
|
|
|
isDebug :: Machine Bool
|
|
isDebug = get >>= (return . _debug)
|
|
|
|
getAt :: Int -> String -> ExceptT String Machine Int
|
|
getAt index err = do
|
|
vm <- lift $ get
|
|
let stack = _stack vm
|
|
case (stack S.!? index) of
|
|
(Just i) -> return i
|
|
Nothing -> throwError err
|
|
|
|
getStackSize :: Machine Int
|
|
getStackSize = get >>= (return . length . _stack)
|
|
|
|
setPc :: Int -> Machine ()
|
|
setPc pc = do
|
|
vm <- get
|
|
put vm { _pc = pc }
|
|
|
|
setFp :: Int -> Machine ()
|
|
setFp fp = do
|
|
vm <- get
|
|
put vm { _fp = fp }
|
|
|
|
setHalt :: Bool -> Machine ()
|
|
setHalt halt = do
|
|
vm <- get
|
|
put vm { _halt = halt }
|
|
|
|
pop :: Int -> Machine [Int]
|
|
pop count = do
|
|
vm <- get
|
|
let stack = _stack vm
|
|
put vm { _stack = S.drop count $ stack }
|
|
return $ toList $ S.take count $ stack
|
|
|
|
push :: [Int] -> Machine ()
|
|
push = pushS . S.fromList
|
|
|
|
pushS :: S.Seq Int -> Machine ()
|
|
pushS numbers = do
|
|
vm <- get
|
|
put vm { _stack = numbers <> _stack vm }
|
|
return ()
|
|
|
|
forward :: Int -> Machine ()
|
|
forward offset = do
|
|
vm <- get
|
|
put vm { _pc = _pc vm + offset }
|
|
return () |