patternMinor
Primitive stack-based code interpreter
Viewed 0 times
interpreterstackprimitivebasedcode
Problem
I've written an interpreter for a simple assembly-like language and it's performing slower than I would like.
It's split into 3 files: the Parser that converts the source to a vector of ints, the VM that actually runs the bytecode, and Tests that has a bubble sort written in the language.
It sorts 100 numbers in about 6 seconds in GHCi. The profiler doesn't tell me much except that the most time is spent inside the step function as it's expected.
The Parser file isn't that needed because it's only run once so it doesn't affect performance.
Another thing to note is that it takes around 250 000 ticks (instructions executed) to do it so I'm pretty sure it could be much faster than 6 seconds.
Is there anything obvious that I could improve?
Parser
VM
```
module VM where
import Parser (ByteCode, OpCode(..), arity)
import qualified Data.IntMap as IM
import Data.Vector (Vector, (!))
import qualified
It's split into 3 files: the Parser that converts the source to a vector of ints, the VM that actually runs the bytecode, and Tests that has a bubble sort written in the language.
It sorts 100 numbers in about 6 seconds in GHCi. The profiler doesn't tell me much except that the most time is spent inside the step function as it's expected.
The Parser file isn't that needed because it's only run once so it doesn't affect performance.
Another thing to note is that it takes around 250 000 ticks (instructions executed) to do it so I'm pretty sure it could be much faster than 6 seconds.
Is there anything obvious that I could improve?
Parser
module Parser where
import Data.Vector (Vector, fromList)
import Data.Char (toUpper)
import Data.List (sort)
type ByteCode = [Int]
data OpCode = Push | Pop | Add | Sub | Mult | Div | Store | Load | Jmp | Cmp | Not | Br | Dup | Inc | Dec | Swp
deriving (Enum, Read, Show, Ord, Eq)
arity :: Vector Int
arity = (fromList . map snd . sort) $ zip [Push, Store, Load] [1, 1..] ++ zip [Pop, Add, Sub, Mult, Div] [0, 0..]
charIsNumeric :: Char -> Bool
charIsNumeric c = '0' = c
stringIsNumeric :: String -> Bool
stringIsNumeric ('-' : s) = all charIsNumeric s
stringIsNumeric s = all charIsNumeric s
capitalize :: String -> String
capitalize [] = []
capitalize (x : xs) = toUpper x : xs
wordToByteCode :: String -> Int
wordToByteCode str = if stringIsNumeric str then read str else fromEnum opCodeEnum
where
opCodeEnum :: OpCode
opCodeEnum = read $ capitalize str
stringToByteCode :: String -> ByteCode
stringToByteCode = map wordToByteCode . words
sourceToByteCode :: String -> ByteCode
sourceToByteCode = map wordToByteCode . concatMap words . linesVM
```
module VM where
import Parser (ByteCode, OpCode(..), arity)
import qualified Data.IntMap as IM
import Data.Vector (Vector, (!))
import qualified
Solution
Based on my investigations, I'm going to say that your problem is exactly what I said in the comments: performance testing with ghci.
I modified VM.hs a bit, to get it to build:
My changes were:
I also changed
After those changes, this is a sample session:
```
carl@debian:~/hask/codereview/stackint$ ghc -O2 -main-is Tests Tests.hs
[1 of 3] Compiling Parser ( Parser.hs, Parser.o )
[2 of 3] Compiling VM ( VM.hs, VM.o )
[3 of 3] Compiling Tests ( Tests.hs, Tests.o )
Linking Tests ...
carl@debian:~/hask/codereview/stackint$ time ./Tests
(267252,VM {byteCode = fromList [0,0,0,1000,6,0,0,0,1001,6,0,1000,7,7,0,1001,7,7,9,0,38,11,0,1000,7,7,0,1001,7,7,0,1000,7,6,0,1001,7,6,0,1001,7,13,12,0,1001,6,0,100,9,10,0,10,11,0,0,0,1001,6,0,1000,7,13,12,0,1000,6,0,100,9,10,0,10,11], programCounter = 73, stack = [], memory = fromList [(0,0),(1,1),(2,2),(3,3),(4,4),(5,5),(6,6),(7,7),(8,8),(9,9),(10,10),(11,11),(12,12),(13,13),(14,14),(15,15),(16,16),(17,17),(18,18),(19,19),(20,20),(21,21),(22,22),(23,23),(24,24),(25,25),(26,26),(27,27),(28,28),(29,29),(30,30),(31,31),(32,32),(33,33),(34,34),(35,35),(36,36),(37,37),(38,38),(39,39),(40,40),(41,41),(42,42),(43,43),(44,44),(45,45),(46,46),(47,47),(48,48),(49,49),(50,50),(51,51),(52,52),(53,53),(54,54),(55,55),(56,56),(57,57),(58,58),(59,59),(60,60),(61,61),(62,62),(63,63),(64,64),(65,65),(66,66),(67,67),(68,68),(69,69),(70,70),(71,71),(72,72),(73,73),(74,74),(75,75),(76,76),(77,77),(78,78),(79,79),(80,80),(81,81),(82,82),(83,83),(84,84),(85,85),(86,86),(87,87),(88,88),(89,89),(90,90),(91,91),(92,92),(93,93),(94,94),(95,95),(96,96),(97,97),(98,98),(99,99),(100,100),(1000,101
I modified VM.hs a bit, to get it to build:
{-# LANGUAGE BangPatterns #-}
module VM where
import Parser (ByteCode, OpCode(..), arity)
import qualified Data.IntMap as IM
import Data.Vector (Vector, (!))
import qualified Data.Vector as Vector
import Data.List (intercalate)
data VM = VM {
byteCode :: Vector Int,
programCounter :: Int,
stack :: [Int],
memory :: IM.IntMap Int
}
deriving (Show)
fromCode :: ByteCode -> VM
fromCode code = VM { byteCode = Vector.fromList code, programCounter = 0, stack = [], memory = IM.empty }
step :: VM -> VM
step vm = next
where
bc = byteCode vm
pc = programCounter vm
st = stack vm
mm = memory vm
inst = toEnum $ bc ! pc
pop1 = tail st
pop2 = tail pop1
top1 = head st
top2 = head pop1
nextPc = pc + 1
next = case inst of
Pop -> vm { stack = pop1, programCounter = nextPc }
Push -> vm { stack = bc ! nextPc : st, programCounter = pc + 2 }
Add -> vm { stack = (top1 + top2) : pop2, programCounter = nextPc }
Sub -> vm { stack = (top2 - top1) : pop2, programCounter = nextPc }
Mult -> vm { stack = (top1 * top2) : pop2, programCounter = nextPc }
Div -> vm { stack = (top2 `div` top1) : pop2, programCounter = nextPc }
Store -> vm { stack = pop2, programCounter = nextPc, memory = IM.insert top1 top2 mm }
Load -> vm { stack = mm IM.! top1 : pop1, programCounter = nextPc }
Jmp -> vm { stack = pop1, programCounter = top1 }
Cmp -> vm { stack = signum (top2 - top1) : pop2, programCounter = nextPc }
Not -> vm { stack = (if top1 > 0 then -1 else 1) : pop1, programCounter = nextPc }
Br -> vm { stack = pop2, programCounter = if top2 > 0 then top1 else nextPc }
Dup -> vm { stack = top1 : st, programCounter = nextPc }
Inc -> vm { stack = (top1 + 1) : pop1, programCounter = nextPc }
Dec -> vm { stack = (top1 - 1) : pop1, programCounter = nextPc }
Swp -> vm { stack = top2 : top1 : pop2, programCounter = nextPc }
endState :: VM -> Bool
endState vm = programCounter vm == Vector.length (byteCode vm)
run :: VM -> VM
run = until endState step
runCount :: VM -> (Int, VM)
runCount = untilCount endState step
where
untilCount f g = go 0
where
go !n x | f x = (n, x)
| otherwise = go (n + 1) (g x)
debug :: (VM -> String) -> VM -> (VM, [String])
debug watch vm = if endState vm then (vm, []) else (nextVm, watch vm : logs)
where
(nextVm, logs) = debug watch (step vm)
instructionLogger :: VM -> String
instructionLogger vm = show (toEnum $ byteCode vm ! programCounter vm :: OpCode)
watch :: Int -> VM -> String
watch n vm = case IM.lookup n (memory vm) of
Nothing -> "undefined"
Just a -> show a
composeLoggers :: [VM -> String] -> VM -> String
composeLoggers loggers vm = (intercalate " " . map ($ vm)) loggers
printDebug :: (VM -> String) -> VM -> IO ()
printDebug f v = putStr $ unlines $ snd $ debug f vMy changes were:
- Enable the
BangPatternsextension to make it easier to efficiently writeuntilCount
- Remove the import of
Utility.
- Add
untilCountintorunCount.
I also changed
Tests to use runCount just to be sure I was getting the same operation count as you.After those changes, this is a sample session:
```
carl@debian:~/hask/codereview/stackint$ ghc -O2 -main-is Tests Tests.hs
[1 of 3] Compiling Parser ( Parser.hs, Parser.o )
[2 of 3] Compiling VM ( VM.hs, VM.o )
[3 of 3] Compiling Tests ( Tests.hs, Tests.o )
Linking Tests ...
carl@debian:~/hask/codereview/stackint$ time ./Tests
(267252,VM {byteCode = fromList [0,0,0,1000,6,0,0,0,1001,6,0,1000,7,7,0,1001,7,7,9,0,38,11,0,1000,7,7,0,1001,7,7,0,1000,7,6,0,1001,7,6,0,1001,7,13,12,0,1001,6,0,100,9,10,0,10,11,0,0,0,1001,6,0,1000,7,13,12,0,1000,6,0,100,9,10,0,10,11], programCounter = 73, stack = [], memory = fromList [(0,0),(1,1),(2,2),(3,3),(4,4),(5,5),(6,6),(7,7),(8,8),(9,9),(10,10),(11,11),(12,12),(13,13),(14,14),(15,15),(16,16),(17,17),(18,18),(19,19),(20,20),(21,21),(22,22),(23,23),(24,24),(25,25),(26,26),(27,27),(28,28),(29,29),(30,30),(31,31),(32,32),(33,33),(34,34),(35,35),(36,36),(37,37),(38,38),(39,39),(40,40),(41,41),(42,42),(43,43),(44,44),(45,45),(46,46),(47,47),(48,48),(49,49),(50,50),(51,51),(52,52),(53,53),(54,54),(55,55),(56,56),(57,57),(58,58),(59,59),(60,60),(61,61),(62,62),(63,63),(64,64),(65,65),(66,66),(67,67),(68,68),(69,69),(70,70),(71,71),(72,72),(73,73),(74,74),(75,75),(76,76),(77,77),(78,78),(79,79),(80,80),(81,81),(82,82),(83,83),(84,84),(85,85),(86,86),(87,87),(88,88),(89,89),(90,90),(91,91),(92,92),(93,93),(94,94),(95,95),(96,96),(97,97),(98,98),(99,99),(100,100),(1000,101
Code Snippets
{-# LANGUAGE BangPatterns #-}
module VM where
import Parser (ByteCode, OpCode(..), arity)
import qualified Data.IntMap as IM
import Data.Vector (Vector, (!))
import qualified Data.Vector as Vector
import Data.List (intercalate)
data VM = VM {
byteCode :: Vector Int,
programCounter :: Int,
stack :: [Int],
memory :: IM.IntMap Int
}
deriving (Show)
fromCode :: ByteCode -> VM
fromCode code = VM { byteCode = Vector.fromList code, programCounter = 0, stack = [], memory = IM.empty }
step :: VM -> VM
step vm = next
where
bc = byteCode vm
pc = programCounter vm
st = stack vm
mm = memory vm
inst = toEnum $ bc ! pc
pop1 = tail st
pop2 = tail pop1
top1 = head st
top2 = head pop1
nextPc = pc + 1
next = case inst of
Pop -> vm { stack = pop1, programCounter = nextPc }
Push -> vm { stack = bc ! nextPc : st, programCounter = pc + 2 }
Add -> vm { stack = (top1 + top2) : pop2, programCounter = nextPc }
Sub -> vm { stack = (top2 - top1) : pop2, programCounter = nextPc }
Mult -> vm { stack = (top1 * top2) : pop2, programCounter = nextPc }
Div -> vm { stack = (top2 `div` top1) : pop2, programCounter = nextPc }
Store -> vm { stack = pop2, programCounter = nextPc, memory = IM.insert top1 top2 mm }
Load -> vm { stack = mm IM.! top1 : pop1, programCounter = nextPc }
Jmp -> vm { stack = pop1, programCounter = top1 }
Cmp -> vm { stack = signum (top2 - top1) : pop2, programCounter = nextPc }
Not -> vm { stack = (if top1 > 0 then -1 else 1) : pop1, programCounter = nextPc }
Br -> vm { stack = pop2, programCounter = if top2 > 0 then top1 else nextPc }
Dup -> vm { stack = top1 : st, programCounter = nextPc }
Inc -> vm { stack = (top1 + 1) : pop1, programCounter = nextPc }
Dec -> vm { stack = (top1 - 1) : pop1, programCounter = nextPc }
Swp -> vm { stack = top2 : top1 : pop2, programCounter = nextPc }
endState :: VM -> Bool
endState vm = programCounter vm == Vector.length (byteCode vm)
run :: VM -> VM
run = until endState step
runCount :: VM -> (Int, VM)
runCount = untilCount endState step
where
untilCount f g = go 0
where
go !n x | f x = (n, x)
| otherwise = go (n + 1) (g x)
debug :: (VM -> String) -> VM -> (VM, [String])
debug watch vm = if endState vm then (vm, []) else (nextVm, watch vm : logs)
where
(nextVm, logs) = debug watch (step vm)
instructionLogger :: VM -> String
instructionLogger vm = show (toEnum $ byteCode vm ! programCounter vm :: OpCode)
watch :: Int -> VM -> String
watch n vm = case IM.lookup n (memory vm) of
Nothing -> "undefined"
Just a -> show a
composeLoggers :: [VM -> String] -> VM -> String
composeLoggers loggers vm = (intercalate " " . map ($ vm)) loggers
printDebug :: (VM -> Stricarl@debian:~/hask/codereview/stackint$ ghc -O2 -main-is Tests Tests.hs
[1 of 3] Compiling Parser ( Parser.hs, Parser.o )
[2 of 3] Compiling VM ( VM.hs, VM.o )
[3 of 3] Compiling Tests ( Tests.hs, Tests.o )
Linking Tests ...
carl@debian:~/hask/codereview/stackint$ time ./Tests
(267252,VM {byteCode = fromList [0,0,0,1000,6,0,0,0,1001,6,0,1000,7,7,0,1001,7,7,9,0,38,11,0,1000,7,7,0,1001,7,7,0,1000,7,6,0,1001,7,6,0,1001,7,13,12,0,1001,6,0,100,9,10,0,10,11,0,0,0,1001,6,0,1000,7,13,12,0,1000,6,0,100,9,10,0,10,11], programCounter = 73, stack = [], memory = fromList [(0,0),(1,1),(2,2),(3,3),(4,4),(5,5),(6,6),(7,7),(8,8),(9,9),(10,10),(11,11),(12,12),(13,13),(14,14),(15,15),(16,16),(17,17),(18,18),(19,19),(20,20),(21,21),(22,22),(23,23),(24,24),(25,25),(26,26),(27,27),(28,28),(29,29),(30,30),(31,31),(32,32),(33,33),(34,34),(35,35),(36,36),(37,37),(38,38),(39,39),(40,40),(41,41),(42,42),(43,43),(44,44),(45,45),(46,46),(47,47),(48,48),(49,49),(50,50),(51,51),(52,52),(53,53),(54,54),(55,55),(56,56),(57,57),(58,58),(59,59),(60,60),(61,61),(62,62),(63,63),(64,64),(65,65),(66,66),(67,67),(68,68),(69,69),(70,70),(71,71),(72,72),(73,73),(74,74),(75,75),(76,76),(77,77),(78,78),(79,79),(80,80),(81,81),(82,82),(83,83),(84,84),(85,85),(86,86),(87,87),(88,88),(89,89),(90,90),(91,91),(92,92),(93,93),(94,94),(95,95),(96,96),(97,97),(98,98),(99,99),(100,100),(1000,101),(1001,0)]})
real 0m0.155s
user 0m0.012s
sys 0m0.116simport Criterion.Main
import qualified VM
import qualified Tests
main :: IO ()
main = defaultMain [bench "sort" $ whnf (fst . VM.runCount) Tests.vmWithData]carl@debian:~/hask/codereview/stackint$ ghc -O2 Main.hs
[3 of 4] Compiling Tests ( Tests.hs, Tests.o ) [flags changed]
[4 of 4] Compiling Main ( Main.hs, Main.o )
Linking Main ...
carl@debian:~/hask/codereview/stackint$ ./Main
warming up
estimating clock resolution...
mean is 21.01945 us (40001 iterations)
found 2284 outliers among 39999 samples (5.7%)
678 (1.7%) low severe
1345 (3.4%) high severe
estimating cost of a clock call...
mean is 16.59960 us (6 iterations)
benchmarking sort
collecting 100 samples, 1 iterations each, in estimated 6.015491 s
mean: 52.26690 ms, lb 50.39930 ms, ub 57.08317 ms, ci 0.950
std dev: 14.30133 ms, lb 6.851806 ms, ub 29.74848 ms, ci 0.950
found 7 outliers among 100 samples (7.0%)
3 (3.0%) high mild
4 (4.0%) high severe
variance introduced by outliers: 96.804%
variance is severely inflated by outliersdata VM = VM {
byteCode :: Vector Int,
programCounter :: !Int,
stack :: [Int],
memory :: !(IM.IntMap Int)
}
deriving (Show)Context
StackExchange Code Review Q#57605, answer score: 3
Revisions (0)
No revisions yet.