never executed always true always false
1 {-# LANGUAGE FlexibleContexts #-}
2 {-# LANGUAGE RecordWildCards #-}
3 {-# LANGUAGE ScopedTypeVariables #-}
4 {-# OPTIONS_GHC -fno-full-laziness #-}
5
6 {-|
7 Description : Brainfuck Virtual Machine
8 Copyright : (c) Sebastian Galkin, 2018
9 License : GPL-3
10
11 Functions to evaluate a compiled Brainfuck program.
12 -}
13 module HBF.Eval
14 ( MachineType
15 , eval
16 , evalWith
17 , evalWithIO
18 , evalWithMachine
19 , emptyMachine
20 , mkMachine
21 , VMOptions(..)
22 , defaultVMOptions
23 , unsafeParse
24 , parse
25 , parsePure
26 ) where
27
28 import Control.Monad (replicateM_, when)
29 import Control.Monad.Primitive (PrimMonad, PrimState)
30 import Data.Coerce (coerce)
31 import Data.Int (Int8)
32 import Data.Maybe (fromMaybe)
33 import Data.Monoid ((<>))
34 import qualified Data.Vector.Fusion.Stream.Monadic as VStream
35 import qualified Data.Vector.Generic as GV
36 import qualified Data.Vector.Generic.Mutable as MV
37 import qualified Data.Vector.Unboxed
38 import Options.Applicative
39 import System.Environment (getArgs)
40
41 import HBF.Types
42
43 -- | An alias for a 'Machine' in which memory is an unboxed vector of bytes.
44 type MachineType = Machine (Data.Vector.Unboxed.Vector Int8)
45
46 {-# INLINABLE eval #-}
47 -- | Evaluate the given program returning the end state of the 'Machine'. The evaluation can
48 -- happen in any 'PrimMonad' for which we can do I/O. The reason to use 'PrimState' is that
49 -- we will use mutable vectors for the evaluation.
50 eval :: (PrimMonad m, MachineIO m) => Program Optimized -> m MachineType
51 eval = evalWithMachine defaultVMOptions emptyMachine
52
53 {-# INLINABLE evalWith #-}
54 -- | Evaluate the given program returning the end state of the 'Machine'. The evaluation can
55 -- happen in any 'PrimMonad' for which we can do I/O. The reason to use 'PrimState' is that
56 -- we will use mutable vectors for the evaluation. 'VMOptions' are used to tune the details
57 -- of the VM, like available memory, verbosity, etc.
58 evalWith ::
59 (PrimMonad m, MachineIO m)
60 => VMOptions
61 -> Program Optimized
62 -> m MachineType
63 evalWith opts program =
64 evalWithMachine opts (mkMachine (vmOptsMemoryBytes opts)) program
65
66 {-# INLINABLE evalWithIO #-}
67 -- | Evaluate the given program returning the end state of the 'Machine'. The evaluation
68 -- happens in IO, so Input/Output is done to the console.
69 evalWithIO :: VMOptions -> Program Optimized -> IO MachineType
70 evalWithIO opts program = do
71 machine <- evalWith opts program
72 when (vmOptsDumpMemory opts) $ print machine
73 return machine
74
75 {-# SPECIALISE evalWithMachine ::
76 VMOptions -> MachineType -> Program Optimized -> IO MachineType #-}
77
78 {-# INLINABLE evalWithMachine #-}
79 -- | Evaluate the given program returning the end state of the 'Machine'. The evaluation can
80 -- happen in any 'PrimMonad' for which we can do I/O. The reason to use 'PrimState' is that
81 -- we will use mutable vectors for the evaluation. 'VMOptions' are used to tune the details
82 -- of the VM, like memory available, verbosity, etc. The evaluation starts with the specified
83 -- 'MachineType', so the memory and initial pointer can be configured before running.
84 evalWithMachine ::
85 forall m. (PrimMonad m, MachineIO m)
86 => VMOptions
87 -> MachineType
88 -> Program Optimized
89 -> m MachineType
90 evalWithMachine _ Machine {..} program = do
91 mem <- GV.thaw memory
92 finalPointer <- mutableEval (instructions program) mem 0
93 finalMemory <- GV.unsafeFreeze mem
94 return Machine {memory = finalMemory, pointer = finalPointer}
95 -- For some reason making this function a top level binding brings down performance by compiling
96 -- without native arithmetic. Even if we add SPECIALIZE pragma
97 -- Maybe this is the reason why we also need -fno-full-laziness
98 where
99 mutableEval ::
100 forall v. (MV.MVector v Int8)
101 => [Op]
102 -> v (PrimState m) Int8
103 -> MemOffset
104 -> m MemOffset
105 mutableEval [] _ pos = return pos
106 mutableEval (op:ops) mem pos =
107 case op of
108 Inc n memOffset ->
109 MV.unsafeModify mem (+ fromIntegral n) (o2i $ pos + memOffset) *>
110 mutableEval ops mem pos
111 Move n -> mutableEval ops mem (pos + coerce n)
112 Out times memOffset -> do
113 val <- MV.unsafeRead mem (o2i $ pos + memOffset)
114 replicateM_ times (putByte val)
115 mutableEval ops mem pos
116 In times memOffset ->
117 if times == 0
118 then mutableEval ops mem pos
119 else let input :: m (Maybe Int8)
120 input =
121 foldr (flip (*>)) (return Nothing) $
122 replicate times getByte
123 in do input >>=
124 MV.write mem (o2i $ pos + memOffset) . fromMaybe 0
125 mutableEval ops mem pos
126 Loop l -> do
127 let go pos' = do
128 condition <- MV.unsafeRead mem (o2i pos')
129 if condition == 0
130 then mutableEval ops mem pos'
131 else (do pos'' <- mutableEval l mem pos'
132 go pos'')
133 go pos
134 Clear offset ->
135 MV.unsafeWrite mem (o2i $ pos + offset) 0 *> mutableEval ops mem pos
136 Mul factor from to -> do
137 x <- MV.unsafeRead mem (o2i $ pos + from)
138 MV.unsafeModify
139 mem
140 (\old -> old + x * factor2i factor)
141 (o2i $ pos + from + to)
142 mutableEval ops mem pos
143 Scan Up offset ->
144 let start = o2i $ pos + offset
145 slice :: v (PrimState m) Int8
146 slice = MV.slice start (MV.length mem - start) mem
147 in do Just idx <- VStream.findIndex (== 0) (MV.mstream slice) -- todo error handling
148 mutableEval ops mem (MemOffset $ start + idx)
149 Scan Down offset ->
150 let end = o2i $ pos + offset
151 slice :: v (PrimState m) Int8
152 slice = MV.slice 0 (end + 1) mem
153 in do Just idx <- VStream.findIndex (== 0) (MV.mstreamR slice) -- todo error handling
154 mutableEval ops mem (MemOffset $ end - idx)
155
156 o2i :: MemOffset -> Int
157 o2i = coerce
158
159 {-# INLINE o2i #-}
160 factor2i :: MulFactor -> Int8
161 factor2i = fromIntegral . (coerce :: MulFactor -> Int)
162
163 {-# INLINE factor2i #-}
164 -- | Size of the default VM memory, in bytes.
165 machineSize :: Word
166 machineSize = 30000
167
168 -- | A VM 'Machine' with the default memory available.
169 emptyMachine :: MachineType
170 emptyMachine = mkMachine machineSize
171
172 -- | Create a new machine with the given memory
173 mkMachine :: Word -> MachineType
174 mkMachine n = Machine {memory = GV.replicate (fromIntegral n) 0, pointer = 0}
175
176 -- | Command line arguments for the VM evaluator.
177 data VMOptions = VMOptions
178 { vmOptsMemoryBytes :: Word -- ^ Available memory in bytes.
179 , vmOptsDumpMemory :: Bool -- ^ Dump the contents of the memory after executing a program
180 , vmOptsProgramPath :: FilePath -- ^ Path to the compiled program
181 } deriving (Show)
182
183 -- | Default configuration for the VM.
184 defaultVMOptions :: VMOptions
185 defaultVMOptions =
186 VMOptions
187 { vmOptsMemoryBytes = 30000
188 , vmOptsDumpMemory = False
189 , vmOptsProgramPath = ""
190 }
191
192 optionsP :: Parser VMOptions
193 optionsP =
194 (\mem dump input ->
195 VMOptions
196 { vmOptsMemoryBytes = mem
197 , vmOptsDumpMemory = dump
198 , vmOptsProgramPath = input
199 }) <$>
200 option
201 auto
202 (long "memory" <> short 'm' <> metavar "BYTES" <>
203 value (vmOptsMemoryBytes defaultVMOptions) <>
204 help "Size of the memory [in bytes] used to run the program") <*>
205 switch
206 (long "dump-memory" <> short 'd' <>
207 help "Dump the contents of the memory when the program is finished") <*>
208 argument str (metavar "PROGRAM" <> help "Path to the compiled program")
209
210 parserInfo :: ParserInfo VMOptions
211 parserInfo =
212 info
213 (optionsP <**> helper)
214 (fullDesc <> progDesc "Run the compiled Brainfuck program in PROGRAM file" <>
215 header "An optimizing Brainfuck compiler and evaluator")
216
217 -- | Parse a list of command line arguments
218 parsePure :: [String] -> ParserResult VMOptions
219 parsePure = execParserPure defaultPrefs parserInfo
220
221 -- | Parse a list of command line arguments printing errors to the stderr
222 unsafeParse :: [String] -> IO VMOptions
223 unsafeParse = handleParseResult . parsePure
224
225 -- | Parse command line arguments printing errors to the stderr
226 parse :: IO VMOptions
227 parse = getArgs >>= unsafeParse