bartek/mvm
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge Instruction to VirtualMachine module

Browse Source
This commit is contained in:
Bartłomiej Przemysław Pluta
2021-11-02 23:39:02 +01:00
parent c919e391b2
commit 85a27b7fb1
5 changed files with 109 additions and 118 deletions
Download Patch File Download Diff File Expand all files Collapse all files

3
MVM.cabal
View File

@@ -26,9 +26,8 @@ executable MVM
-- Modules included in this executable, other than Main.
other-modules:
VirtualMachine
Instruction
Parser
Interpreter
Parser
Util
-- LANGUAGE extensions used by modules in this package.

94
app/Instruction.hs
View File

@@ -1,94 +0,0 @@
module Instruction (
Op(..),
Instruction(..),
Command(..),
instructions,
instructionByOp,
toOp
) where
import Data.Foldable
import qualified Data.Char as Char
import qualified Data.Map as Map
import qualified Data.Sequence as S
import qualified VirtualMachine as VM
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
deriving (Eq, Ord, Enum, Show, Read, Bounded)
type Args = [Int]
type Pops = [Int]
type Pushes = S.Seq Int
data Instruction = Simple { op :: Op
, noParams :: Int
, noPops :: Int
, sAction :: Args -> Pops -> Pushes
}
| Complex { op :: Op
, noParams :: Int
, cAction :: VM.VM -> Args -> Either String VM.VM
}
data Command = Command { instr :: Instruction
, args :: [Int]
}
instructions :: [Instruction]
instructions = [ Simple { op = Nop, noParams = 0, noPops = 0, sAction = (\_ _ -> S.empty) }
, Simple { op = Push, noParams = 1, noPops = 0, sAction = (\args _ -> S.fromList args) }
, Simple { op = Pop, noParams = 0, noPops = 1, sAction = (\_ _ -> S.empty) }
, Simple { op = Dup, noParams = 0, noPops = 1, sAction = (\_ [x] -> S.fromList [x, x]) }
, Simple { op = Swap, noParams = 0, noPops = 2, sAction = (\_ [x, y] -> S.fromList [y, x]) }
, Simple { op = Add, noParams = 0, noPops = 2, sAction = (\_ [x, y] -> S.fromList [y + x]) }
, Simple { op = Sub, noParams = 0, noPops = 2, sAction = (\_ [x, y] -> S.fromList [y - x]) }
, Simple { op = Mul, noParams = 0, noPops = 2, sAction = (\_ [x, y] -> S.fromList [y * x]) }
, Simple { op = Div, noParams = 0, noPops = 2, sAction = (\_ [x, y] -> S.fromList [y `div` x]) }
, Simple { op = Neg, noParams = 0, noPops = 1, sAction = (\_ [x] -> S.fromList [-x]) }
, Simple { op = Not, noParams = 0, noPops = 1, sAction = (\_ [x] -> S.fromList [if x /= 0 then 0 else 1]) }
, Complex { op = Halt, noParams = 0, cAction = (\vm _ -> Right $ vm { VM.halt = True }) }
, Complex { op = Jmp, noParams = 1, cAction = (\vm [x] -> Right $ vm { VM.pc = x}) }
, Complex { op = Je, noParams = 1, cAction = jumpIf (==) }
, Complex { op = Jne, noParams = 1, cAction = jumpIf (/=) }
, Complex { op = Jg, noParams = 1, cAction = jumpIf (>) }
, Complex { op = Jl, noParams = 1, cAction = jumpIf (<) }
, Complex { op = Jge, noParams = 1, cAction = jumpIf (>=) }
, Complex { op = Jle, noParams = 1, cAction = jumpIf (<=) }
]
jumpIf :: (Int -> Int -> Bool) -> VM.VM -> Args -> Either String VM.VM
jumpIf predicate vm [addr] = Right $ vm { VM.pc = pc' }
where
(top:_) = toList . VM.stack $ vm
pc' = if top `predicate` 0 then addr else VM.pc vm + 1
instructionByOp :: Map.Map Op Instruction
instructionByOp = Map.fromList $ map (\i -> (op i, i)) instructions
toOp :: String -> Op
toOp = read . capitalize
where capitalize :: String -> String
capitalize [] = []
capitalize (x:xs) = Char.toUpper x : map Char.toLower xs

19
app/Interpreter.hs
View File

@@ -7,26 +7,25 @@ import Control.Monad
import Data.Foldable
import qualified Data.Sequence as S
import qualified Instruction as I
import qualified VirtualMachine as VM
interpret :: [I.Command] -> VM.VM -> Either String VM.VM
interpret :: [VM.Command] -> VM.VM -> Either String VM.VM
interpret _ vm@(VM.VM _ _ _ True) = Right $ vm
interpret cmds vm = do
vm' <- interpretCommand cmds vm
interpret cmds vm'
interpretCommand :: [I.Command] -> VM.VM -> Either String VM.VM
interpretCommand :: [VM.Command] -> VM.VM -> Either String VM.VM
interpretCommand [] _ = Left $ "Empty code"
interpretCommand cmds vm@(VM.VM pc _ _ _)
| pc >= length cmds = Right $ vm { VM.halt = True }
| otherwise = case instr of
(I.Simple _ _ _ _) -> interpretSimple vm cmd
(I.Complex _ _ _) -> interpretComplex vm cmd
where cmd@(I.Command instr _) = cmds !! pc
(VM.Simple _ _ _ _) -> interpretSimple vm cmd
(VM.Complex _ _ _) -> interpretComplex vm cmd
where cmd@(VM.Command instr _) = cmds !! pc
interpretSimple :: VM.VM -> I.Command -> Either String VM.VM
interpretSimple vm (I.Command (I.Simple op _ noPops operation) args) = vm'
interpretSimple :: VM.VM -> VM.Command -> Either String VM.VM
interpretSimple vm (VM.Command (VM.Simple op _ noPops operation) args) = vm'
where
pops = toList . S.take noPops . VM.stack $ vm
stack' = Right $ operation args pops
@@ -35,6 +34,6 @@ interpretSimple vm (I.Command (I.Simple op _ noPops operation) args) = vm'
})
interpretSimple _ _ = Left "Unknown operation"
interpretComplex :: VM.VM -> I.Command -> Either String VM.VM
interpretComplex vm (I.Command (I.Complex _ _ operation) args) = operation vm args
interpretComplex :: VM.VM -> VM.Command -> Either String VM.VM
interpretComplex vm (VM.Command (VM.Complex _ _ operation) args) = operation vm args
interpretComplex _ _ = Left "Unknown operation"

16
app/Parser.hs
View File

@@ -6,23 +6,23 @@ import Data.Word
import qualified Data.ByteString as B
import qualified Data.Map as Map
import qualified Instruction as I
import qualified VirtualMachine as VM
import qualified Util as U
parse :: B.ByteString -> Either String [I.Command]
parse :: B.ByteString -> Either String [VM.Command]
parse = parseCommands . B.unpack
parseCommands :: [Word8] -> Either String [I.Command]
parseCommands :: [Word8] -> Either String [VM.Command]
parseCommands [] = Right []
parseCommands code@(x:_) = case parseCommand code of
Just (cmd, rest) -> parseCommands rest >>= (\r -> return $ cmd : r)
Nothing -> Left $ "Unparseable byte: " ++ U.byteStr x ++ "\nIn following sequence:\n" ++ U.bytesStr 16 code
parseCommand :: [Word8] -> Maybe (I.Command, [Word8])
parseCommand :: [Word8] -> Maybe (VM.Command, [Word8])
parseCommand [] = Nothing
parseCommand (opByte:xs) = do
let op = toEnum . fromIntegral $ opByte :: I.Op
instruction <- Map.lookup op I.instructionByOp
let noParams = I.noParams instruction
let op = toEnum . fromIntegral $ opByte :: VM.Op
instruction <- Map.lookup op VM.instructionByOp
let noParams = VM.noParams instruction
let params = map fromIntegral $ take noParams xs :: [Int]
return (I.Command instruction params, drop noParams xs)
return (VM.Command instruction params, drop noParams xs)

95
app/VirtualMachine.hs
View File

@@ -1,9 +1,17 @@
module VirtualMachine (
VM(..),
empty
)
where
Op(..),
Instruction(..),
Command(..),
empty,
instructions,
instructionByOp,
toOp
) where
import Data.Foldable
import qualified Data.Char as Char
import qualified Data.Map as Map
import qualified Data.Sequence as S
data VM = VM { pc :: Int
@@ -12,9 +20,88 @@ data VM = VM { pc :: Int
, halt :: 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
deriving (Eq, Ord, Enum, Show, Read, Bounded)
type Args = [Int]
type Pops = [Int]
type Pushes = S.Seq Int
data Instruction = Simple { op :: Op
, noParams :: Int
, noPops :: Int
, sAction :: Args -> Pops -> Pushes
}
| Complex { op :: Op
, noParams :: Int
, cAction :: VM -> Args -> Either String VM
}
data Command = Command { instr :: Instruction
, args :: [Int]
}
empty :: VM
empty = VM { pc = 0
, fp = -1
, stack = S.empty
, halt = False
}
}
instructions :: [Instruction]
instructions = [ Simple { op = Nop, noParams = 0, noPops = 0, sAction = (\_ _ -> S.empty) }
, Simple { op = Push, noParams = 1, noPops = 0, sAction = (\args _ -> S.fromList args) }
, Simple { op = Pop, noParams = 0, noPops = 1, sAction = (\_ _ -> S.empty) }
, Simple { op = Dup, noParams = 0, noPops = 1, sAction = (\_ [x] -> S.fromList [x, x]) }
, Simple { op = Swap, noParams = 0, noPops = 2, sAction = (\_ [x, y] -> S.fromList [y, x]) }
, Simple { op = Add, noParams = 0, noPops = 2, sAction = (\_ [x, y] -> S.fromList [y + x]) }
, Simple { op = Sub, noParams = 0, noPops = 2, sAction = (\_ [x, y] -> S.fromList [y - x]) }
, Simple { op = Mul, noParams = 0, noPops = 2, sAction = (\_ [x, y] -> S.fromList [y * x]) }
, Simple { op = Div, noParams = 0, noPops = 2, sAction = (\_ [x, y] -> S.fromList [y `div` x]) }
, Simple { op = Neg, noParams = 0, noPops = 1, sAction = (\_ [x] -> S.fromList [-x]) }
, Simple { op = Not, noParams = 0, noPops = 1, sAction = (\_ [x] -> S.fromList [if x /= 0 then 0 else 1]) }
, Complex { op = Halt, noParams = 0, cAction = (\vm _ -> Right $ vm { halt = True }) }
, Complex { op = Jmp, noParams = 1, cAction = (\vm [x] -> Right $ vm { pc = x}) }
, Complex { op = Je, noParams = 1, cAction = jumpIf (==) }
, Complex { op = Jne, noParams = 1, cAction = jumpIf (/=) }
, Complex { op = Jg, noParams = 1, cAction = jumpIf (>) }
, Complex { op = Jl, noParams = 1, cAction = jumpIf (<) }
, Complex { op = Jge, noParams = 1, cAction = jumpIf (>=) }
, Complex { op = Jle, noParams = 1, cAction = jumpIf (<=) }
]
jumpIf :: (Int -> Int -> Bool) -> VM -> Args -> Either String VM
jumpIf predicate vm [addr] = Right $ vm { pc = pc' }
where
(top:_) = toList . stack $ vm
pc' = if top `predicate` 0 then addr else pc vm + 1
instructionByOp :: Map.Map Op Instruction
instructionByOp = Map.fromList $ map (\i -> (op i, i)) instructions
toOp :: String -> Op
toOp = read . capitalize
where capitalize :: String -> String
capitalize [] = []
capitalize (x:xs) = Char.toUpper x : map Char.toLower xs